\ The Rest is Silence 26Sep83map************************************************************* ************************************************************* *** *** *** Please direct all questions, comments, and *** *** miscellaneous personal abuse to: *** *** *** *** Henry Laxen or Michael Perry *** *** 1259 Cornell Avenue 1125 Bancroft Way *** *** Berkeley, California Berkeley, California *** *** 94706 94702 *** *** *** *** (415) 525-8582 (415) 644-3421 *** *** *** ************************************************************* ************************************************************* \ Load Screen for Pre-Compile 23OCT83HHLONLY FORTH ALSO DEFINITIONS 101 CONSTANT VERSION : NLOAD CR .S (LOAD) ; ' NLOAD IS LOAD 3 21 THRU ( The Meta Compiler ) ONLY FORTH DEFINITIONS ALSO CR .( Meta Compiler Loaded ) --> \ Target System Setup 11NOV83HHLONLY FORTH ' NLOAD IS LOAD META ALSO FORTH 256 DP-T ! HERE 12000 + ' TARGET-ORIGIN >BODY ! IN-META 24 113 THRU ( System Source Screens ) CR .( Unresolved references: ) CR .UNRESOLVED CR .( Statistics: ) CR .( Last Host Address: ) [FORTH] HERE U. CR .( First Target Code Address: ) META 256 THERE U. CR .( Last Target Code Address: ) META HERE-T THERE U. CR CR ( MS-DOS only ) ONLY FORTH ALSO CP/M ' NOOP IS HEADER META 256 THERE HERE-T CP/M SAVE KERNEL86.COM \ META 256 THERE HERE-T CP/M SAVE KERNEL86.CMD CR .( Now return to CP/M and type: ) CR .( KERNEL86 EXTEND86.BLK <CR> ) CR .( START <CR> ) \ Vocabulary Helpers 07SEP83HHLONLY FORTH ALSO VOCABULARY META META ALSO META DEFINITIONS VARIABLE DP-T : [FORTH] FORTH ; IMMEDIATE : [META] META ; IMMEDIATE : SWITCH (S -- ) NOOP ( Context ) NOOP ( Current ) DOES> DUP @ CONTEXT @ SWAP CONTEXT ! OVER ! 2+ DUP @ CURRENT @ SWAP CURRENT ! SWAP ! ; SWITCH ( Redefine itself ) \ Memory Access Words 15OCT82HHL0 CONSTANT TARGET-ORIGIN : THERE (S taddr -- addr ) TARGET-ORIGIN + ; : C@-T (S taddr -- char ) THERE C@ ; : @-T (S taddr -- n ) THERE @ ; : C!-T (S char taddr -- ) THERE C! ; : !-T (S n taddr -- ) THERE ! ; : HERE-T (S -- taddr ) DP-T @ ; : ALLOT-T (S n -- ) DP-T +! ; : C,-T (S char -- ) HERE-T C!-T 1 ALLOT-T ; : ,-T (S n -- ) HERE-T !-T 2 ALLOT-T ; : S,-T (S addr len -- ) 0 ?DO DUP C@ C,-T 1+ LOOP DROP ; \ Define Symbol Table Vocabularies 07SEP83HHLVOCABULARY TARGET VOCABULARY TRANSITION VOCABULARY FORWARD VOCABULARY USER ONLY DEFINITIONS FORTH ALSO META ALSO : META META ; : TARGET TARGET ; : TRANSITION TRANSITION ; : ASSEMBLER ASSEMBLER ; : FORWARD FORWARD ; : USER USER ; ONLY FORTH ALSO META ALSO DEFINITIONS \ Define Meta Branching Constructs 08OCT83HHL: ?>MARK (S -- f addr ) TRUE HERE-T 0 ,-T ; : ?>RESOLVE (S f addr -- ) HERE-T SWAP !-T ?CONDITION ; : ?<MARK (S -- f addr ) TRUE HERE-T ; : ?<RESOLVE (S f addr -- ) ,-T ?CONDITION ; \ 8086 Meta Assembler 08OCT83HHL: M?>MARK (S -- f addr ) TRUE HERE-T 0 C,-T ; : M?>RESOLVE (S f addr -- ) HERE-T OVER 1+ - SWAP C!-T ?CONDITION ; : M?<MARK (S -- f addr ) TRUE HERE-T ; : M?<RESOLVE (S f addr -- ) HERE-T 1+ - C,-T ?CONDITION ; ' C,-T ASSEMBLER IS C, ' ,-T ASSEMBLER IS , ' HERE-T ASSEMBLER IS HERE ' M?>MARK ASSEMBLER IS ?>MARK ' M?>RESOLVE ASSEMBLER IS ?>RESOLVE ' M?<MARK ASSEMBLER IS ?<MARK ' M?<RESOLVE ASSEMBLER IS ?<RESOLVE ONLY FORTH ALSO META ALSO DEFINITIONS \ Meta Compiler Vocabulary Manipulators 25OCT82HHL: MAKE-CODE (S PFA -- ) @ ,-T ; : LABEL (S -- ) ASSEMBLER DEFINITIONS HERE-T CONSTANT ; : IN-TARGET (S -- ) ONLY TARGET DEFINITIONS ; : IN-TRANSITION (S -- ) ONLY FORWARD ALSO TARGET DEFINITIONS ALSO TRANSITION ; : IN-META (S -- ) ONLY FORTH ALSO META DEFINITIONS ALSO ; : IN-FORWARD (S -- ) FORWARD DEFINITIONS ; \ Meta Compiler Forward Reference Linking 07SEP83HHL: LINK-BACKWARDS (S PFA -- ) HERE-T OVER @ ,-T SWAP ! ; : RESOLVED? (S pfa -- f ) 2+ C@ ; : FORWARD-CODE (S pfa -- ) DUP RESOLVED? IF MAKE-CODE ELSE LINK-BACKWARDS THEN ; : FORWARD: (S -- ) SWITCH FORWARD DEFINITIONS CREATE SWITCH 0 , 0 C, DOES> FORWARD-CODE ; \ Create Headers in Target Image 16Oct83mapVARIABLE WIDTH 31 WIDTH ! VARIABLE LAST-T VARIABLE CONTEXT-T VARIABLE CURRENT-T : HASH (S str-addr voc-addr -- thread ) SWAP 1+ C@ #THREADS 1- AND 2* + ; : HEADER (S -- ) BL WORD C@ 1+ WIDTH @ MIN ?DUP IF ALIGN BLK @ 4096 + ,-T ( Lay down view field ) HERE CURRENT-T @ HASH DUP @-T ,-T HERE-T 2- SWAP !-T HERE-T HERE ROT S,-T ALIGN DUP LAST-T ! 128 SWAP THERE CSET 128 HERE-T 1- THERE CSET THEN ; \ Meta Compiler Create Target Image 07OCT83HHL: TARGET-CREATE (S -- ) >IN @ HEADER >IN ! IN-TARGET CREATE IN-META HERE-T , 1 C, DOES> MAKE-CODE ; : RECREATE (S -- ) >IN @ TARGET-CREATE >IN ! ; : CODE TARGET-CREATE HERE-T 2+ ,-T ASSEMBLER !CSP ; ASSEMBLER ALSO DEFINITIONS : C; IN-META ?CSP ; META IN-META \ Force compilation of target & forward words 07SEP83HHL: 'T (S -- cfa ) CONTEXT @ TARGET DEFINED ROT CONTEXT ! 0= ?MISSING ; : [TARGET] (S -- ) 'T , ; IMMEDIATE : 'F (S -- cfa ) CONTEXT @ FORWARD DEFINED ROT CONTEXT ! 0= ?MISSING ; : [FORWARD] (S -- ) 'F , ; IMMEDIATE \ Meta Compiler Branching & Defining Words 07SEP83HHL: T: (S -- ) SWITCH TRANSITION DEFINITIONS CREATE SWITCH ] DOES> >R ; : T; (S -- ) SWITCH TRANSITION DEFINITIONS [COMPILE] ; SWITCH ; IMMEDIATE : DIGIT? (S CHAR -- F ) BASE @ DIGIT NIP ; : PUNCT? (S CHAR -- F ) ASCII . OVER = SWAP ASCII - OVER = SWAP ASCII / OVER = SWAP DROP OR OR ; : NUMERIC? (S ADDR LEN -- F ) DUP 1 = IF DROP C@ DIGIT? EXIT THEN 1 -ROT 0 ?DO DUP C@ DUP DIGIT? SWAP PUNCT? OR ROT AND SWAP 1+ LOOP DROP ; \ Meta Compiler Transition Words 04MAR83HHLT: ( [COMPILE] ( T; T: (S [COMPILE] (S T; T: \ [COMPILE] \ T; : STRING,-T (S -- ) ASCII " WORD DUP C@ 1+ S,-T ; FORWARD: <(.")> T: ." [FORWARD] <(.")> STRING,-T T; FORWARD: <(")> T: " [FORWARD] <(")> STRING,-T T; FORWARD: <(ABORT")> T: ABORT" [FORWARD] <(ABORT")> STRING,-T T; \ Meta Compiler Defining Words 06SEP83HHLFORWARD: <VARIABLE> : CREATE RECREATE [FORWARD] <VARIABLE> HERE-T CONSTANT ; : VARIABLE (S -- ) CREATE 0 ,-T ; FORWARD: <DEFER> : DEFER (S -- ) TARGET-CREATE [FORWARD] <DEFER> 0 ,-T ; \ Meta Compiler Defining Words 07SEP83HHLFORTH VARIABLE #USER-T META ALSO USER DEFINITIONS : ALLOT (S n -- ) #USER-T +! ; FORWARD: <USER-VARIABLE> : VARIABLE (S -- ) SWITCH RECREATE [FORWARD] <USER-VARIABLE> #USER-T @ DUP ,-T 2 ALLOT META DEFINITIONS CONSTANT SWITCH ; FORWARD: <USER-DEFER> : DEFER (S -- ) SWITCH TARGET-CREATE [FORWARD] <USER-DEFER> SWITCH #USER-T @ ,-T 2 ALLOT ; ONLY FORTH ALSO META ALSO DEFINITIONS \ Meta Compiler Transition Words 16Oct83mapFORTH VARIABLE VOC-LINK-T META FORWARD: <VOCABULARY> : VOCABULARY (S -- ) RECREATE [FORWARD] <VOCABULARY> HERE-T #THREADS 0 DO 0 ,-T LOOP ( THREADS ) HERE-T VOC-LINK-T @ ,-T VOC-LINK-T ! CONSTANT DOES> @ CONTEXT-T ! ; : IMMEDIATE (S -- ) WIDTH @ IF ( Headers present? ) 64 ( Precedence Bit ) LAST-T @ THERE CTOGGLE THEN ; \ Meta Compiler Transition Words 06SEP83HHLFORWARD: <(;USES)> FORTH VARIABLE STATE-T META T: ;USES (S -- ) [FORWARD] <(;USES)> IN-META ASSEMBLER !CSP STATE-T OFF T; T: [COMPILE] 'T EXECUTE T; FORWARD: <(IS)> T: IS [FORWARD] <(IS)> T; : IS 'T >BODY @ >BODY !-T ; T: ALIGN T; T: EVEN T; \ Display an unformatted Symbol Table 26Sep83map: .SYMBOLS (S -- ) TARGET CONTEXT @ HERE #THREADS 2* CMOVE BEGIN HERE 4 LARGEST DUP WHILE ?CR ." [[ " DUP .ID DUP NAME> >BODY @ U. ." ]] " N>LINK @ SWAP ! KEY? IF EXIT THEN REPEAT 2DROP IN-META ; \ Meta Compiler Resolve Forward References 26Sep83map: .UNRESOLVED (S -- ) FORWARD CONTEXT @ HERE #THREADS 2* CMOVE BEGIN HERE #THREADS LARGEST DUP WHILE ?CR DUP L>NAME NAME> >BODY RESOLVED? 0= IF DUP L>NAME .ID THEN @ SWAP ! REPEAT 2DROP IN-META ; : FIND-UNRESOLVED (S -- cfa f ) 'F DUP >BODY RESOLVED? ; : RESOLVE (S taddr cfa -- ) >BODY 2DUP 1 OVER 2+ C! @ BEGIN DUP WHILE 2DUP @-T -ROT SWAP !-T REPEAT 2DROP ! ; : RESOLVES (S taddr -- ) FIND-UNRESOLVED IF >NAME .ID ." Already Resolved" DROP ELSE RESOLVE THEN ; \ Interpretive words for Meta 07SEP83HHL: H: [COMPILE] : ; H: ' 'T >BODY @ ; H: , ,-T ; H: C, C,-T ; H: HERE HERE-T ; H: ALLOT ALLOT-T ; H: DEFINITIONS DEFINITIONS CONTEXT-T @ CURRENT-T ! ; \ Declare the Forward References and Version # 29Sep83map: ]] ] ; : [[ [COMPILE] [ ; FORTH IMMEDIATE META FORWARD: DEFINITIONS FORWARD: [ \ Boot up Vectors and NEXT Interpreter 04OCT83HHLASSEMBLER LABEL ORIGIN HERE 8000 + #) JMP \ jump to cold start: will be patched HERE 8000 + #) JMP \ jump to warm start: will be patched LABEL DPUSH DX PUSH LABEL APUSH AX PUSH LABEL >NEXT AX LODS AX W MOV 0 [W] JMP H: 2PUSH META ASSEMBLER DPUSH #) JMP ; H: 1PUSH META ASSEMBLER APUSH #) JMP ; H: NEXT META ASSEMBLER >NEXT #) JMP ; HERE-T DUP 100 + CURRENT-T ! ( harmless ) VOCABULARY FORTH FORTH DEFINITIONS 0 OVER 2+ !-T ( link ) DUP 2+ SWAP 16 + !-T ( thread ) IN-META \ Run Time Code for Defining Words 11OCT83HHLASSEMBLER LABEL NEST W INC W INC RP DEC RP DEC IP 0 [RP] MOV W IP MOV NEXT META CODE EXIT (S -- ) 0 [RP] IP MOV RP INC RP INC NEXT C; CODE UNNEST ' EXIT @-T ' UNNEST !-T C; ASSEMBLER LABEL DODOES SP RP XCHG IP PUSH SP RP XCHG IP POP W INC W INC W PUSH NEXT LABEL DOCREATE W INC W INC W PUSH NEXT META \ Run Time Code for Defining Words 11OCT83HHLVARIABLE UP LABEL DOCONSTANT W INC W INC 0 [W] AX MOV 1PUSH C; LABEL DOUSER-VARIABLE W INC W INC 0 [W] AX MOV UP #) AX ADD 1PUSH C; CODE (LIT) (S -- n ) AX LODS 1PUSH C; \ Meta Defining Words 07SEP83HHLT: LITERAL (S n -- ) [TARGET] (LIT) ,-T T; T: DLITERAL (S d -- ) [TARGET] (LIT) ,-T [TARGET] (LIT) ,-T T; T: ASCII (S -- ) [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META] T; T: ['] (S -- ) 'T >BODY @ [[ TRANSITION ]] LITERAL [META] T; : CONSTANT (S n -- ) RECREATE [[ ASSEMBLER DOCONSTANT ]] LITERAL ,-T DUP ,-T CONSTANT ; \ Identify numbers and forward References 04OCT83HHLFORWARD: <(;CODE)> T: DOES> (S -- ) [FORWARD] <(;CODE)> HERE-T ( DOES-OP ) 232 C,-T [[ ASSEMBLER DODOES ]] LITERAL HERE 2+ - ,-T T; : NUMERIC (S -- ) [FORTH] HERE [META] NUMBER DPL @ 1+ IF [[ TRANSITION ]] DLITERAL [META] ELSE DROP [[ TRANSITION ]] LITERAL [META] THEN ; : UNDEFINED (S -- ) HERE-T 0 ,-T IN-FORWARD [FORTH] CREATE [META] TRANSITION [FORTH] , 0 C, [META] DOES> FORWARD-CODE ; \ Meta Compiler Compiling Loop 04MAR83HHL[FORTH] VARIABLE T-IN META : ] (S -- ) STATE-T ON IN-TRANSITION BEGIN >IN @ T-IN ! DEFINED IF EXECUTE ELSE COUNT NUMERIC? IF NUMERIC ELSE T-IN @ >IN ! UNDEFINED THEN THEN STATE-T @ 0= UNTIL ; T: [ (S -- ) IN-META STATE-T OFF T; T: ; (S -- ) [TARGET] UNNEST [[ TRANSITION ]] [ T; : : (S -- ) TARGET-CREATE [[ ASSEMBLER NEST ]] LITERAL ,-T ] ; \ Run Time Code for Control Structures 04OCT83HHLCODE BRANCH (S -- ) LABEL BRAN1 0 [IP] IP MOV NEXT C; CODE ?BRANCH (S f -- ) AX POP AX AX OR BRAN1 JE IP INC IP INC NEXT C; \ Meta Compiler Branching Words 01AUG83HHLT: BEGIN ?<MARK T; T: AGAIN [TARGET] BRANCH ?<RESOLVE T; T: UNTIL [TARGET] ?BRANCH ?<RESOLVE T; T: IF [TARGET] ?BRANCH ?>MARK T; T: THEN ?>RESOLVE T; T: ELSE [TARGET] BRANCH ?>MARK 2SWAP ?>RESOLVE T; T: WHILE [[ TRANSITION ]] IF T; T: REPEAT 2SWAP [[ TRANSITION ]] AGAIN THEN T; \ Run Time Code for Control Structures 04OCT83HHLCODE (LOOP) (S -- ) 1 # AX MOV LABEL PLOOP AX 0 [RP] ADD BRAN1 JNO 6 # RP ADD IP INC IP INC NEXT C; CODE (+LOOP) (S n -- ) AX POP PLOOP #) JMP C; \ Run Time Code for Control Structures 11OCT83HHLHEX CODE (DO) (S l i -- ) AX POP BX POP LABEL PDO RP DEC RP DEC 0 [IP] DX MOV DX 0 [RP] MOV IP INC IP INC 8000 # BX ADD RP DEC RP DEC BX 0 [RP] MOV BX AX SUB RP DEC RP DEC AX 0 [RP] MOV NEXT C; DECIMAL CODE (?DO) (S l i -- ) AX POP BX POP AX BX CMP PDO JNE 0 [IP] IP MOV NEXT C; : BOUNDS (S adr len -- lim first ) OVER + SWAP ; \ Meta compiler Branching & Looping 01AUG83HHLT: ?DO [TARGET] (?DO) ?>MARK T; T: DO [TARGET] (DO) ?>MARK T; T: LOOP [TARGET] (LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE T; T: +LOOP [TARGET] (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE T; \ Execution Control 04OCT83HHLASSEMBLER >NEXT META CONSTANT >NEXT CODE EXECUTE (S cfa -- ) W POP 0 [W] JMP C; CODE PERFORM (S addr-of-cfa -- ) W POP 0 [W] W MOV 0 [W] JMP C; LABEL DODEFER (S -- ) W INC W INC 0 [W] W MOV 0 [W] JMP C; LABEL DOUSER-DEFER W INC W INC 0 [W] AX MOV UP #) AX ADD AX W MOV 0 [W] W MOV 0 [W] JMP C; CODE GO (S addr -- ) RET C; CODE NOOP NEXT C; CODE PAUSE NEXT C; \ Execution Control 11OCT83HHLCODE I (S -- n ) 0 [RP] AX MOV 2 [RP] AX ADD 1PUSH C; CODE J (S -- n ) 6 [RP] AX MOV 8 [RP] AX ADD 1PUSH C; DECIMAL CODE (LEAVE) (S -- ) LABEL PLEAVE 4 # RP ADD 0 [RP] IP MOV RP INC RP INC NEXT C; CODE (?LEAVE) (S f -- ) AX POP AX AX OR PLEAVE JNE NEXT C; T: LEAVE [TARGET] (LEAVE) T; T: ?LEAVE [TARGET] (?LEAVE) T; \ 16 and 8 bit Memory Operations 22Aug83mapCODE @ (S addr -- n ) BX POP 0 [BX] PUSH NEXT C; CODE ! (S n addr -- ) BX POP 0 [BX] POP NEXT C; CODE C@ (S addr -- char ) BX POP AX AX SUB 0 [BX] AL MOV 1PUSH C; CODE C! (S char addr -- ) BX POP AX POP AL 0 [BX] MOV NEXT C; \ Block Move Memory Operations 11OCT83HHLCODE CMOVE (S from to count -- ) CLD IP BX MOV DS AX MOV AX ES MOV CX POP DI POP IP POP REP BYTE MOVS BX IP MOV NEXT C; CODE CMOVE> (S from to count -- ) STD IP BX MOV DS AX MOV AX ES MOV CX POP CX DEC DI POP IP POP CX DI ADD CX IP ADD CX INC REP BYTE MOVS BX IP MOV CLD NEXT C; \ 16 bit Stack Operations 22Aug83mapCODE SP@ (S -- n ) SP AX MOV 1PUSH C; CODE SP! (S n -- ) SP POP NEXT C; CODE RP@ (S -- addr ) RP AX MOV 1PUSH C; CODE RP! (S n -- ) RP POP NEXT C; \ 16 bit Stack Operations 22Aug83mapCODE DROP (S n1 -- ) AX POP NEXT C; CODE DUP (S n1 -- n1 n1 ) AX POP AX PUSH 1PUSH C; CODE SWAP (S n1 n2 -- n2 n1 ) DX POP AX POP 2PUSH C; CODE OVER (S n1 n2 -- n1 n2 n1 ) DX POP AX POP AX PUSH 2PUSH C; \ 16 bit Stack Operations 22Aug83mapCODE TUCK (S n1 n2 -- n2 n1 n2 ) AX POP DX POP AX PUSH 2PUSH C; CODE NIP (S n1 n2 -- n2 ) AX POP DX POP 1PUSH C; CODE ROT (S n1 n2 n3 --- n2 n3 n1 ) DX POP BX POP AX POP BX PUSH 2PUSH C; CODE -ROT (S n1 n2 n3 --- n3 n1 n2 ) BX POP AX POP DX POP BX PUSH 2PUSH C; CODE FLIP (S n1 -- n2 ) AX POP AH AL XCHG 1PUSH C; : ?DUP (S n -- [n] n ) DUP IF DUP THEN ; \ 16 bit Stack Operations 11OCT83HHLCODE R> (S -- n ) 0 [RP] AX MOV RP INC RP INC 1PUSH C; CODE >R (S n -- ) AX POP RP DEC RP DEC AX 0 [RP] MOV NEXT C; CODE R@ (S -- n ) 0 [RP] AX MOV 1PUSH C; CODE PICK (S nm ... n2 n1 k -- nm ... n2 n1 nk ) BX POP BX SHL SP BX ADD 0 [BX] AX MOV 1PUSH C; : ROLL (S n1 n2 .. nk n -- wierd ) >R R@ PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \ 16 bit Logical Operations 22Aug83mapCODE AND (S n1 n2 -- n3 ) BX POP AX POP BX AX AND 1PUSH C; CODE OR (S n1 n2 -- n3 ) BX POP AX POP BX AX OR 1PUSH C; CODE XOR (S n1 n2 -- n3 ) BX POP AX POP BX AX XOR 1PUSH C; CODE NOT (S n -- n' ) AX POP AX NOT 1PUSH C; -1 CONSTANT TRUE 0 CONSTANT FALSE \ Logical Operations 16Oct83mapCODE CSET (S b addr -- ) BX POP AX POP AL 0 [BX] OR NEXT C; CODE CRESET (S b addr -- ) BX POP AX POP AX NEG AL 0 [BX] AND NEXT C; CODE CTOGGLE (S b addr -- ) BX POP AX POP AL 0 [BX] XOR NEXT C; CODE ON (S addr -- ) BX POP TRUE # 0 [BX] MOV NEXT C; CODE OFF (S addr -- ) BX POP FALSE # 0 [BX] MOV NEXT C; \ 16 bit Arithmetic Operations 11OCT83HHLCODE + (S n1 n2 -- sum ) BX POP AX POP BX AX ADD 1PUSH C; CODE NEGATE (S n -- n' ) AX POP AX NEG 1PUSH C; CODE - (S n1 n2 -- n1-n2 ) BX POP AX POP BX AX SUB 1PUSH C; CODE ABS (S n -- n ) AX POP AX AX OR 0< IF AX NEG THEN 1PUSH C; CODE +! (S n addr -- ) BX POP AX POP AX 0 [BX] ADD NEXT C; 0 CONSTANT 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 \ 16 bit Arithmetic Operations 11OCT83HHLCODE 2* (S n -- 2*n ) AX POP AX SHL 1PUSH C; CODE 2/ (S n -- n/2 ) AX POP AX SAR 1PUSH C; CODE U2/ (S u -- u/2 ) AX POP AX SHR 1PUSH C; CODE 8* (S n -- 8*n ) AX POP AX SHL AX SHL AX SHL 1PUSH C; CODE 1+ AX POP AX INC 1PUSH C; CODE 2+ AX POP AX INC AX INC 1PUSH C; CODE 1- AX POP AX DEC 1PUSH C; CODE 2- AX POP AX DEC AX DEC 1PUSH C; \ 16 bit Arithmetic Operations Unsigned Multiply 22Aug83mapCODE UM* (S n1 n2 -- d ) AX POP BX POP BX MUL DX AX XCHG 2PUSH C; : U*D (S n1 n2 -- d ) UM* ; \ 16 bit Arithmetic Operations Unsigned Divide 22Aug83mapCODE UM/MOD (S d1 n1 -- Remainder Quotient ) BX POP DX POP AX POP BX DX CMP >= ( divide by zero? ) IF -1 # AX MOV AX DX MOV 2PUSH THEN BX DIV 2PUSH C; \ 16 bit Comparison Operations 04OCT83HHLASSEMBLER LABEL YES TRUE # AX MOV 1PUSH LABEL NO FALSE # AX MOV 1PUSH CODE 0= (S n -- f ) AX POP AX AX OR YES JE NO #) JMP C; CODE 0< (S n -- f ) AX POP AX AX OR YES JS NO #) JMP C; CODE 0> (S n -- f ) AX POP AX AX OR YES JG NO #) JMP C; CODE 0<> (S n -- f ) AX POP AX AX OR YES JNE NO #) JMP C; CODE = (S n1 n2 -- f ) AX POP BX POP AX BX CMP YES JE NO #) JMP C; : <> (S n1 n2 -- f ) = NOT ; : ?NEGATE (S n1 n2 -- n3 ) 0< IF NEGATE THEN ; \ 16 bit Comparison Operations 11OCT83HHLASSEMBLER LABEL YES TRUE # AX MOV 1PUSH CODE U< (S n1 n2 -- f ) AX POP BX POP AX BX CMP YES JB NO #) JMP C; CODE U> (S n1 n2 -- f ) AX POP BX POP BX AX CMP YES JB NO #) JMP C; CODE < (S n1 n2 -- f ) AX POP BX POP AX BX CMP YES JL NO #) JMP C; CODE > (S n1 n2 -- f ) AX POP BX POP AX BX CMP YES JG NO #) JMP C; : MIN (S n1 n2 -- n3 ) 2DUP > IF SWAP THEN DROP ; : MAX (S n1 n2 -- n3 ) 2DUP < IF SWAP THEN DROP ; : BETWEEN (S n1 min max -- f ) >R OVER > SWAP R> > OR NOT ; : WITHIN (S n1 min max -- f ) 1- BETWEEN ; \ 32 bit Memory Operations 22Aug83mapCODE 2@ (S addr -- d ) BX POP 0 [BX] AX MOV BX INC BX INC 0 [BX] DX MOV 2PUSH C; CODE 2! (S d addr -- ) BX POP 0 [BX] POP BX INC BX INC 0 [BX] POP NEXT C; \ 32 bit Memory and Stack Operations 11OCT83HHLCODE 2DROP (S d -- ) AX POP AX POP NEXT C; CODE 2DUP (S d -- d d ) AX POP DX POP DX PUSH AX PUSH 2PUSH C; CODE 2SWAP (S d1 d2 -- d2 d1 ) CX POP BX POP AX POP DX POP BX PUSH CX PUSH 2PUSH C; CODE 2OVER (S d2 d2 -- d1 d2 d1 ) CX POP BX POP AX POP DX POP DX PUSH AX PUSH BX PUSH CX PUSH 2PUSH C; : 3DUP (S a b c -- a b c a b c ) DUP 2OVER ROT ; : 4DUP (S a b c d -- a b c d a b c d ) 2OVER 2OVER ; : 2ROT (S a b c d e f - c d e f a b ) 5 ROLL 5 ROLL ; \ 32 bit Arithmetic Operations 11OCT83HHLCODE D+ (S d1 d2 -- dsum ) AX POP DX POP BX POP CX POP CX DX ADD BX AX ADC 2PUSH C; CODE DNEGATE (S d# -- d#' ) BX POP CX POP AX AX SUB AX DX MOV CX DX SUB BX AX SBB 2PUSH C; CODE S>D (S n -- d ) AX POP CWD AX DX XCHG 2PUSH C; CODE DABS (S d# -- d# ) DX POP DX PUSH DX DX OR ' DNEGATE @-T JS NEXT C; \ 32 bit Arithmetic Operations 04OCT83HHLCODE D2/ (S d -- d/2 ) DX POP AX POP AX SAR DX RCR AX PUSH DX PUSH NEXT C; : D- (S d1 d2 -- d3 ) DNEGATE D+ ; : ?DNEGATE (S d1 n -- d2 ) 0< IF DNEGATE THEN ; \ 32 bit Comparison Operations 01OCT83MAP: D0= (S d -- f ) OR 0= ; : D= (S d1 d2 -- f ) D- D0= ; : DU< (S ud1 ud2 -- f ) ROT SWAP 2DUP U< IF 2DROP 2DROP TRUE ELSE <> IF 2DROP FALSE ELSE U< THEN THEN ; : D< (S d1 d2 -- f ) 2 PICK OVER = IF DU< ELSE NIP ROT DROP < THEN ; : D> (S d1 d2 -- f ) 2SWAP D< ; : DMIN (S d1 d2 -- d3 ) 4DUP D> IF 2SWAP THEN 2DROP ; : DMAX (S d1 d2 -- d3 ) 4DUP D< IF 2SWAP THEN 2DROP ; \ Mixed Mode Arithmetic 04OCT83HHL: *D (S n1 n2 -- d# ) 2DUP XOR >R ABS SWAP ABS UM* R> ?DNEGATE ; : M/MOD (S d# n1 -- rem quot ) ?DUP IF DUP >R 2DUP XOR >R >R DABS R@ ABS UM/MOD SWAP R> ?NEGATE SWAP R> 0< IF NEGATE OVER IF 1- R@ ROT - SWAP THEN THEN R> DROP THEN ; : MU/MOD (S d# n1 -- rem d#quot ) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ 16 bit multiply and divide 04OCT83HHL: * (S n1 n2 -- n3 ) UM* DROP ; : /MOD (S n1 n2 -- rem quot ) >R S>D R> M/MOD ; : / (S n1 n2 -- quot ) /MOD NIP ; : MOD (S n1 n2 -- rem ) /MOD DROP ; : */MOD (S n1 n2 n3 -- rem quot ) >R *D R> M/MOD ; : */ (S n1 n2 n3 -- n1*n2/n3 ) */MOD NIP ; \ Task Dependant USER Variables 16Oct83mapUSER DEFINITIONS VARIABLE TOS ( TOP OF STACK ) VARIABLE ENTRY ( ENTRY POINT, CONTAINS MACHINE CODE ) VARIABLE LINK ( LINK TO NEXT TASK ) VARIABLE SP0 ( INITIAL PARAMETER STACK ) VARIABLE RP0 ( INITIAL RETURN STACK ) VARIABLE DP ( DICTIONARY POINTER ) VARIABLE #OUT ( NUMBER OF CHARACTERS EMITTED ) VARIABLE #LINE ( THE NUMBER OF LINES SENT SO FAR ) VARIABLE OFFSET ( RELATIVE TO ABSOLUTE DISK BLOCK 0 ) VARIABLE BASE ( FOR NUMERIC INPUT AND OUTPUT ) VARIABLE HLD ( POINTS TO LAST CHARACTER HELD IN PAD ) VARIABLE FILE ( POINTS TO FCB OF CURRENTLY OPEN FILE ) VARIABLE PRINTING ( TRUE WHEN PRINTING. EMIT MAY IGNORE ) DEFER EMIT ( TO ALLOW PRINT SPOOLING ) \ System VARIABLEs 16Oct83mapMETA DEFINITIONS VARIABLE SCR ( SCREEN LAST LISTED OR EDITED ) VARIABLE PRIOR ( USED FOR DICTIONARY SEARCHES ) VARIABLE STATE ( COMPILATION OR INTERPRETATION ) VARIABLE WARNING ( GIVE USER DUPLICATE WARNINGS IF ON ) VARIABLE DPL ( NUMERIC INPUT PUNCTUATION ) VARIABLE R# ( EDITING CURSOR POSITION ) VARIABLE LAST ( POINTS TO NFA OF LATEST DEFINITION ) VARIABLE CSP ( HOLDS STACK POINTER FOR ERROR CHECKING ) VARIABLE CURRENT ( VOCABULARY WHICH GETS DEFINITIONS ) 5 CONSTANT #VOCS ( THE NUMBER OF VOCABULARIES TO SEARCH ) VARIABLE CONTEXT ( VOCABULARY SEARCHED FIRST ) 0 , 0 , 0 , 0 , 0 , \ System Variables 29Sep83mapVARIABLE 'TIB ( ADDRESS OF TERMINAL INPUT BUFFER ) VARIABLE WIDTH ( WIDTH OF NAME FIELD ) VARIABLE VOC-LINK ( POINTS TO NEWEST VOCABULARY ) VARIABLE BLK ( BLOCK NUMBER TO INTERPRET ) VARIABLE >IN ( OFFSET INTO INPUT STREAM ) VARIABLE SPAN ( NUMBER OF CHARACTERS EXPECTED ) VARIABLE #TIB ( NUMBER OF CHARACTERS TO INTERPRET ) VARIABLE END? ( TRUE IF INPUT STREAM EXHAUSTED ) \ Devices Strings 04OCT83HHL 32 CONSTANT BL 8 CONSTANT BS 7 CONSTANT BELL VARIABLE CAPS CODE FILL ( start-addr count char -- ) CLD DS AX MOV AX ES MOV AX POP CX POP DI POP REP AL STOS NEXT C; : ERASE (S addr len -- ) 0 FILL ; : BLANK (S addr len -- ) BL FILL ; CODE COUNT (S addr -- addr+1 len ) BX POP AX AX SUB 0 [BX] AL MOV BX INC BX PUSH 1PUSH C; CODE LENGTH (S addr -- addr+2 len ) BX POP 0 [BX] AX MOV BX INC BX INC BX PUSH 1PUSH C; : MOVE ( from to len -- ) -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ; \ Devices Strings 08OCT83HHLASSEMBLER LABEL >UPPER ASCII a # AL CMP 0>= IF ASCII z 1+ # AL CMP 0< IF 32 # AL SUB THEN THEN RET CODE UPPER (S addr len -- ) CX POP BX POP BEGIN CX CX OR 0<> WHILE 0 [BX] AL MOV >UPPER #) CALL AL 0 [BX] MOV BX INC CX DEC REPEAT NEXT C; : HERE (S -- addr ) DP @ ; : PAD (S -- addr ) HERE 80 + ; : -TRAILING (S addr len -- addr len' ) DUP 0 DO 2DUP + 1- C@ BL <> ?LEAVE 1- LOOP ; \ Devices Strings 08OCT83HHLLABEL NOMORE DX SI MOV CX PUSH NEXT CODE COMP (S addr1 addr2 len -- -1 | 0 | 1 ) SI DX MOV CX POP DI POP SI POP NOMORE JCXZ DS AX MOV AX ES MOV REPZ BYTE CMPS NOMORE JE LABEL MISMATCH 0< IF -1 # CX MOV ELSE 1 # CX MOV THEN NOMORE #) JMP C; \ Devices Strings 08OCT83HHLCODE CAPS-COMP (S addr1 addr2 len -- -1 | 0 | 1 ) SI DX MOV CX POP DI POP SI POP BEGIN NOMORE JCXZ 0 [SI] AL MOV >UPPER #) CALL SI INC AL AH MOV 0 [DI] AL MOV >UPPER #) CALL DI INC AL AH CMP MISMATCH JNE CX DEC AGAIN C; : COMPARE (S addr1 addr2 len -- -1 | 0 | 1 ) CAPS @ IF CAPS-COMP ELSE COMP THEN ; \ Devices Terminal IO via CP/M ( or MS-DOS) BDOS 11NOV83HHL\ CODE BDOS (S n fun -- m ) \ CX POP DX POP 224 INT AH AH SUB 1PUSH C; \ : (KEY?) (S -- f ) 254 6 BDOS 0<> ; \ : (KEY) (S -- char ) BEGIN PAUSE (KEY?) UNTIL 255 6 BDOS ; \ For MS-DOS, comment out lines 1 thru 4, and use these: CODE BDOS (S n fun -- m ) AX POP AL AH MOV DX POP 33 INT AH AH SUB 1PUSH C; : (KEY?) (S -- f ) 0 11 BDOS 0<> ; : (KEY) (S -- char ) BEGIN PAUSE (KEY?) UNTIL 0 8 BDOS ; : (EMIT) (S char -- ) PAUSE 6 BDOS DROP 1 #OUT +! ; : (PRINT) (S char -- ) PAUSE 5 BDOS DROP 1 #OUT +! ; \ Devices Terminal Input and Output 27Sep83mapDEFER KEY? DEFER KEY DEFER CR : (PEMIT) (S char -- ) DUP (EMIT) (PRINT) -1 #OUT +! ; : CRLF (S -- ) 13 EMIT 10 EMIT #OUT OFF 1 #LINE +! ; : TYPE (S addr len -- ) 0 ?DO COUNT EMIT LOOP DROP ; : SPACE (S -- ) BL EMIT ; : SPACES (S n -- ) 0 MAX 0 ?DO SPACE LOOP ; : BACKSPACES (S n -- ) 0 ?DO BS EMIT LOOP ; : BEEP (S -- ) BELL EMIT ; \ Devices System Dependent Control Characters 07OCT83HHL: BS-IN (S n c -- 0 | n-1 ) DROP DUP IF 1- BS ELSE BELL THEN EMIT ; : (DEL-IN) (S n c -- 0 | n-1 ) DROP DUP IF 1- BS EMIT SPACE BS ELSE BELL THEN EMIT ; : BACK-UP (S n c -- 0 ) DROP DUP BACKSPACES DUP SPACES BACKSPACES 0 ; : RES-IN (S c -- ) FORTH TRUE ABORT" Reset" ; : P-IN (S c -- ) DROP ['] EMIT >IS DUP @ ['] (EMIT) = IF ['] (PEMIT) ELSE ['] (EMIT) THEN SWAP ! ; \ Devices Terminal Input 07OCT83HHL: CR-IN (S m a n c -- m a m ) DROP SPAN ! OVER BL EMIT ; : (CHAR) (S a n char -- a n+1 ) 3DUP EMIT + C! 1+ ; DEFER CHAR DEFER DEL-IN VARIABLE CC CREATE CC1 ] CHAR CHAR CHAR RES-IN CHAR CHAR CHAR CHAR BS-IN CHAR CHAR CHAR CHAR CR-IN CHAR CHAR P-IN CHAR CHAR CHAR CHAR BACK-UP CHAR CHAR BACK-UP CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \ Devices Terminal Input 29Sep83map: EXPECT (S adr len -- ) DUP SPAN ! SWAP 0 ( len adr 0 ) BEGIN 2 PICK OVER - ( len adr #so-far #left ) WHILE KEY DUP BL < IF DUP 2* CC @ + PERFORM ELSE DUP 127 = IF DEL-IN ELSE CHAR THEN THEN REPEAT 2DROP DROP ; : TIB (S -- adr ) 'TIB @ ; : QUERY (S -- ) TIB 80 EXPECT SPAN @ #TIB ! BLK OFF >IN OFF ; \ Devices BLOCK I/O 27Sep83map 0 CONSTANT FIRST ( Patched by COLD ) 0 CONSTANT LIMIT ( Patched by COLD ) 4 CONSTANT #BUFFERS 1024 CONSTANT B/BUF 128 CONSTANT B/REC 8 CONSTANT REC/BLK 41 CONSTANT B/FCB VARIABLE DISK-ERROR #BUFFERS 1+ 8 * 2+ CONSTANT >SIZE : >BUFFERS (S -- adr ) FIRST >SIZE - ; : >END (S -- adr ) FIRST 2- ; : BUFFER# (S n -- adr ) 8* >BUFFERS + ; \ Devices BLOCK I/O 07OCT83HHLCREATE FCB1 B/FCB ALLOT : CLR-FCB (S -- ) FILE @ DUP B/FCB ERASE 1+ 11 BLANK ; : RECORD# (S -- addr ) FILE @ 33 + ; : MAXREC# (S -- addr ) FILE @ 38 + ; : CAPACITY (S -- n ) MAXREC# @ 1+ 0 8 UM/MOD NIP ; VARIABLE BADREC# : IN-FILE? (S -- ) MAXREC# @ RECORD# @ U< DUP BADREC# ! ABORT" Out of Range" ; : VIEW# (S -- addr ) FILE @ 40 + ; : SET-DRIVE (S drive -- ) 14 BDOS DROP ; : SET-DMA (S address -- ) 26 BDOS DROP ; : REC-READ (S -- ) IN-FILE? FILE @ 33 BDOS DISK-ERROR ! ; : REC-WRITE (S -- ) IN-FILE? FILE @ 34 BDOS DISK-ERROR ! ; \ Devices BLOCK I/O 29Sep83mapDEFER READ-BLOCK (S buffer-header -- ) DEFER WRITE-BLOCK (S buffer-header -- ) : SET-IO (S buf-header -- buffer rec/blk 0 ) DUP @ REC/BLK * RECORD# ! 4 + @ ( buf-addr ) REC/BLK 0 ; : FILE-READ (S buffer-header -- ) SET-IO DO DUP SET-DMA B/REC + REC-READ 1 RECORD# +! LOOP DROP ; : FILE-WRITE (S buffer-header -- ) FILE @ SWAP DUP 2+ @ FILE ! SET-IO DO DUP SET-DMA B/REC + REC-WRITE 1 RECORD# +! LOOP DROP FILE ! ; : FILE-IO (S -- ) ['] FILE-READ IS READ-BLOCK ['] FILE-WRITE IS WRITE-BLOCK ; \ Devices BLOCK I/O 11SEP83HHL: LATEST? (S n -- n | a f ) OFFSET @ + DUP FILE @ SWAP 1 BUFFER# 2@ D= IF DROP 1 BUFFER# 4 + @ FALSE R> DROP THEN ; : ABSENT? (S n -- a f ) LATEST? DUP >BUFFERS ! TRUE SWAP 1 BUFFER# #BUFFERS 0 DO 2DUP @ = IF DUP 2+ @ FILE @ = IF DUP >BUFFERS 8 CMOVE DUP >BUFFERS DUP 8 + ROT >BUFFERS - CMOVE> DROP 2DROP FALSE DUP 1 BUFFER# LEAVE THEN THEN 8 + LOOP 4 + @ NIP SWAP ; \ Devices BLOCK I/O 29Sep83map: UPDATE (S -- ) 1 BUFFER# 6 + ON ; : DISCARD (S -- ) 1 BUFFER# 6 + OFF ; : MISSING (S -- ) >END 2- @ IF >END 8 - WRITE-BLOCK >END 2- OFF THEN FILE @ >BUFFERS 2+ ! >END 4 - @ >BUFFERS 4 + ! ( buffer ) >BUFFERS 6 + OFF >BUFFERS DUP 8 + #BUFFERS 8* CMOVE> ; : BUFFER (S n -- a ) PAUSE ABSENT? IF DROP MISSING 1 BUFFER# 4 + @ THEN ; : BLOCK (S n -- a ) PAUSE ABSENT? IF DROP MISSING 1 BUFFER# DUP READ-BLOCK 4 + @ THEN ; \ Devices BLOCK I/O 29Sep83map: EMPTY-BUFFERS (S -- ) FIRST LIMIT OVER - ERASE >BUFFERS #BUFFERS 1+ 8* ERASE FIRST 1 BUFFER# #BUFFERS 0 DO -1 OVER ! 4 + 2DUP ! SWAP B/BUF + SWAP 4 + LOOP 2DROP ; : SAVE-BUFFERS (S -- ) 1 BUFFER# #BUFFERS 0 DO DUP @ 1+ IF DUP 6 + @ IF DUP WRITE-BLOCK DUP 6 + OFF THEN 8 + THEN LOOP DROP ; : FLUSH (S -- ) SAVE-BUFFERS 0 BLOCK DROP EMPTY-BUFFERS ; \ Devices BLOCK I/O 27Sep83map: FILE-SIZE (S -- n ) FILE @ 35 BDOS DROP RECORD# @ ; : CPM-ERR? (S -- f ) 255 = ; : OPEN-FILE (S -- ) FILE @ 15 BDOS CPM-ERR? ABORT" Can't open file" FILE-SIZE 1- MAXREC# ! ; : MORE (S n -- ) 8* MAXREC# +! ; 92 CONSTANT CPM-FCB : DEFAULT (S -- ) FCB1 FILE ! CLR-FCB CPM-FCB 1+ C@ BL <> IF CPM-FCB FCB1 12 CMOVE OPEN-FILE THEN ; : (LOAD) (S n -- ) BLK @ >R >IN @ >R >IN OFF BLK ! RUN R> >IN ! R> BLK ! ; DEFER LOAD \ Interactive Layer Number Input 04OCT83HHLASSEMBLER LABEL FAIL AX AX SUB 1PUSH CODE DIGIT (S char base -- n f ) DX POP AX POP AX PUSH ASCII 0 # AL SUB FAIL JB 9 # AL CMP > IF 17 # AL CMP FAIL JB 7 # AL SUB THEN DL AL CMP FAIL JAE AL DL MOV AX POP TRUE # AX MOV 2PUSH C; : DOUBLE? (S -- f ) DPL @ 1+ 0<> ; : CONVERT (S +d1 adr1 -- +d2 adr2 ) BEGIN 1+ DUP >R C@ BASE @ DIGIT WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ DOUBLE? IF 1 DPL +! THEN R> REPEAT DROP R> ; \ Interactive Layer Number Input 07OCT83HHL: (NUMBER?) (S adr -- d flag ) 0 0 ROT DUP 1+ C@ ASCII - = DUP >R - -1 DPL ! BEGIN CONVERT DUP C@ ASCII , ASCII / BETWEEN WHILE 0 DPL ! REPEAT -ROT R> IF DNEGATE THEN ROT C@ BL = ; : NUMBER? (S adr -- d flag ) FALSE OVER COUNT BOUNDS ?DO I C@ BASE @ DIGIT NIP IF DROP TRUE LEAVE THEN LOOP IF (NUMBER?) ELSE DROP 0 0 FALSE THEN ; : (NUMBER) (S adr -- d# ) NUMBER? NOT ?MISSING ; DEFER NUMBER \ Interactive Layer Number Output 26sep83map: HOLD (S char -- ) -1 HLD +! HLD @ C! ; : <# (S -- ) PAD HLD ! ; : #> (S d# -- addr len ) 2DROP HLD @ PAD OVER - ; : SIGN (S n1 -- ) 0< IF ASCII - HOLD THEN ; : # (S -- ) BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN ASCII 0 + HOLD ; : #S (S -- ) BEGIN # 2DUP OR 0= UNTIL ; : HEX (S -- ) 16 BASE ! ; : DECIMAL (S -- ) 10 BASE ! ; \ Interactive Layer Number Output 24FEB83HHL: (U.) (S u -- a l ) 0 <# #S #> ; : U. (S u -- ) (U.) TYPE SPACE ; : U.R (S u l -- ) >R (U.) R> OVER - SPACES TYPE ; : (.) (S n -- a l ) DUP ABS 0 <# #S ROT SIGN #> ; : . (S n -- ) (.) TYPE SPACE ; : .R (S n l -- ) >R (.) R> OVER - SPACES TYPE ; : (UD.) (S ud -- a l ) <# #S #> ; : UD. (S ud -- ) (UD.) TYPE SPACE ; : UD.R (S ud l -- ) >R (UD.) R> OVER - SPACES TYPE ; : (D.) (S d -- a l ) TUCK DABS <# #S ROT SIGN #> ; : D. (S d -- ) (D.) TYPE SPACE ; : D.R (S d l -- ) >R (D.) R> OVER - SPACES TYPE ; \ Interactive Layer Parsing 11OCT83HHLLABEL NOMORE ASSEMBLER CX PUSH NEXT CODE SKIP (S addr len char -- addr' len' ) AX POP CX POP NOMORE JCXZ DI POP DS DX MOV DX ES MOV REPZ BYTE SCAS 0<> IF CX INC DI DEC THEN DI PUSH CX PUSH NEXT C; CODE SCAN (S addr len char -- addr' len' ) AX POP CX POP NOMORE JCXZ DI POP DS DX MOV DX ES MOV CX BX MOV REP BYTE SCAS 0= IF CX INC DI DEC THEN DI PUSH CX PUSH NEXT C; \ Interactive Layer Parsing 01Oct83map: /STRING (S addr len n -- addr' len' ) OVER MIN ROT OVER + -ROT - ; : PLACE (S str-addr len to -- ) 2DUP C! 1+ SWAP MOVE ; : (SOURCE) (S -- addr len ) BLK @ ?DUP IF BLOCK B/BUF ELSE TIB #TIB @ THEN ; DEFER SOURCE : PARSE-WORD (S char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R@ SKIP OVER SWAP R> SCAN DROP 2DUP SWAP - >R ROT - 1+ >IN +! R> ; : PARSE (S char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN DROP OVER - DUP 1+ >IN +! ; \ Interactive Layer Parsing 10NOV83HHL: 'WORD (S -- adr ) HERE ; : WORD (S char -- addr ) PARSE-WORD 'WORD PLACE 'WORD DUP COUNT + BL SWAP C! ( Stick Blank at end ) ; : .( (S -- ) ASCII ) PARSE TYPE ; IMMEDIATE : ( (S -- ) 1 SOURCE >IN @ /STRING BOUNDS ?DO I C@ ASCII ( = IF 1+ THEN I C@ ASCII ) = IF 1- THEN 1 >IN +! DUP 0= ?LEAVE LOOP DROP ; IMMEDIATE \ Interactive Layer Dictionary 16Oct83map: X (S -- ) END? ON ; HEX A080 LAST-T @ !-T DECIMAL IMMEDIATE CODE TRAVERSE (S addr direction -- addr' ) CX POP BX POP CX BX ADD BEGIN 0 [BX] AL MOV 128 # AL AND 0= WHILE CX BX ADD REPEAT BX PUSH NEXT C; : DONE? (S n -- f ) STATE @ <> END? @ OR END? OFF ; : FORTH-83 (S -- ) ; : .VERSION (S -- ) [ VERSION ] LITERAL 0 <# # ASCII . HOLD # ASCII . HOLD # #> TYPE SPACE ; \ Interactive Layer Dictionary 27AUG83HHL: N>LINK 2- ; : L>NAME 2+ ; : BODY> 2- ; : NAME> 1 TRAVERSE 1+ ; : LINK> L>NAME NAME> ; : >BODY 2+ ; : >NAME 1- -1 TRAVERSE ; : >LINK >NAME N>LINK ; : >VIEW >LINK 2- ; : VIEW> 2+ LINK> ; \ Interactive Layer Dictionary 05OCT83HHLCODE HASH (S str-addr voc-ptr -- thread ) CX POP BX POP BX INC 0 [BX] AL MOV 3 # AX AND AX SHL CX AX ADD 1PUSH C; CODE (FIND) (S here alf -- cfa flag | here false ) DX POP DX DX OR 0= IF AX AX SUB 1PUSH THEN BEGIN DX BX MOV BX INC BX INC DI POP ( here ) DI PUSH 0 [BX] AL MOV 0 [DI] AL XOR 63 # AL AND 0= IF BEGIN BX INC DI INC 0 [BX] AL MOV 0 [DI] AL XOR 0<> UNTIL 127 # AL AND 0= IF DI POP BX INC BX PUSH DX BX MOV BX INC BX INC 0 [BX] AL MOV 64 # AL AND 0<> IF 1 # AX MOV ELSE -1 # AX MOV THEN 1PUSH THEN THEN DX BX MOV 0 [BX] DX MOV DX DX OR 0= UNTIL AX AX SUB 1PUSH C; \ Interactive Layer Dictionary 11SEP83HHL4 CONSTANT #THREADS : FIND (S addr -- cfa flag | addr false ) PRIOR OFF FALSE #VOCS 0 DO DROP CONTEXT I 2* + @ DUP IF DUP PRIOR @ OVER PRIOR ! = IF DROP FALSE ELSE OVER SWAP HASH @ (FIND) DUP ?LEAVE THEN THEN LOOP ; : DEFINED (S -- here 0 | cfa [ -1 | 1 ] ) BL WORD CAPS @ IF DUP COUNT UPPER THEN FIND ; \ Interactive Layer Interpreter 27Sep83map: ?STACK (S -- ) ( System dependant ) SP@ SP0 @ SWAP U< ABORT" Stack Underflow" SP@ PAD U< ABORT" Stack Overflow" ; DEFER STATUS (S -- ) : INTERPRET (S -- ) BEGIN ?STACK DEFINED IF EXECUTE ELSE NUMBER DOUBLE? NOT IF DROP THEN THEN FALSE DONE? UNTIL ; \ Extensible Layer Compiler 23JUL83HHL: ALLOT (S n -- ) DP +! ; : , (S n -- ) HERE ! 2 ALLOT ; : C, (S char -- ) HERE C! 1 ALLOT ; : ALIGN ; IMMEDIATE ( HERE 1 AND IF BL C, THEN ) : EVEN ; IMMEDIATE ( DUP 1 AND + ) : COMPILE (S -- ) R> DUP 2+ >R @ , ; : IMMEDIATE (S -- ) 64 ( Precedence bit ) LAST @ CTOGGLE ; : LITERAL (S n -- ) COMPILE (LIT) , ; IMMEDIATE : DLITERAL (S d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE : ASCII (S -- n ) BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : CONTROL (S -- n ) BL WORD 1+ C@ ASCII @ - STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE \ Extensible Layer Compiler 08Oct83map: CRASH (S -- ) TRUE ABORT" Uninitialized execution vector." ; : ?MISSING (S f -- ) IF 'WORD COUNT TYPE TRUE ABORT" ?" THEN ; : ' (S -- cfa ) DEFINED 0= ?MISSING ; : ['] (S -- ) ' [COMPILE] LITERAL ; IMMEDIATE : [COMPILE] (S -- ) ' , ; IMMEDIATE : (") (S -- addr len ) R> COUNT 2DUP + EVEN >R ; : (.") (S -- ) R> COUNT 2DUP + EVEN >R TYPE ; : ," (S -- ) ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ALIGN ; : ." (S -- ) COMPILE (.") ," ; IMMEDIATE : " (S -- ) COMPILE (") ," ; IMMEDIATE \ Interactive Layer Dictionary 01OCT83MAPVARIABLE FENCE : TRIM (S faddr voc-addr -- ) #THREADS 0 DO 2DUP @ BEGIN 2DUP U> NOT WHILE @ REPEAT NIP OVER ! 2+ LOOP 2DROP ; : (FORGET) (S addr -- ) DUP FENCE @ U< ABORT" Below fence" DUP VOC-LINK @ BEGIN 2DUP U< WHILE @ REPEAT DUP VOC-LINK ! NIP BEGIN DUP WHILE 2DUP #THREADS 2* - TRIM @ REPEAT DROP DP ! ; : FORGET (S -- ) BL WORD CAPS @ IF DUP COUNT UPPER THEN CURRENT @ OVER SWAP HASH @ (FIND) 0= ?MISSING >VIEW (FORGET) ; \ Extensible Layer Compiler 16Oct83mapDEFER WHERE DEFER ?ERROR : (?ERROR) (S adr len f -- ) IF >R >R SP0 @ SP! PRINTING OFF BLK @ IF >IN @ BLK @ WHERE THEN R> R> SPACE TYPE SPACE QUIT ELSE 2DROP THEN ; : (ABORT") (S f -- ) R@ COUNT ROT ?ERROR R> COUNT + EVEN >R ; : ABORT" (S -- ) COMPILE (ABORT") ," ; IMMEDIATE : ABORT (S -- ) SP0 @ SP! QUIT ; \ Extensible Layer Structures 01Oct83map: ?CONDITION (S f -- ) NOT ABORT" Conditionals Wrong" ; : >MARK (S -- addr ) HERE 0 , ; : >RESOLVE (S addr -- ) HERE SWAP ! ; : <MARK (S -- addr ) HERE ; : <RESOLVE (S addr -- ) , ; : ?>MARK (S -- f addr ) TRUE >MARK ; : ?>RESOLVE (S f addr -- ) SWAP ?CONDITION >RESOLVE ; : ?<MARK (S -- f addr ) TRUE <MARK ; : ?<RESOLVE (S f addr -- ) SWAP ?CONDITION <RESOLVE ; : LEAVE COMPILE (LEAVE) ; IMMEDIATE : ?LEAVE COMPILE (?LEAVE) ; IMMEDIATE \ Extensible Layer Structures 01Oct83map: BEGIN ?<MARK ; IMMEDIATE : THEN ?>RESOLVE ; IMMEDIATE : DO COMPILE (DO) ?>MARK ; IMMEDIATE : ?DO COMPILE (?DO) ?>MARK ; IMMEDIATE : LOOP COMPILE (LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE : +LOOP COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE : UNTIL COMPILE ?BRANCH ?<RESOLVE ; IMMEDIATE : AGAIN COMPILE BRANCH ?<RESOLVE ; IMMEDIATE : REPEAT 2SWAP [COMPILE] AGAIN [COMPILE] THEN ; IMMEDIATE : IF COMPILE ?BRANCH ?>MARK ; IMMEDIATE : ELSE COMPILE BRANCH ?>MARK 2SWAP ?>RESOLVE ; IMMEDIATE : WHILE [COMPILE] IF ; IMMEDIATE \ Extensible Layer Defining Words 16Oct83map: ,VIEW (S -- ) VIEW# @ 4096 * BLK @ + , ; : HEADER (S -- ) ALIGN ,VIEW HERE 0 , ( Temp link field ) HERE LAST ! ( Remember nfa ) WARNING @ IF DEFINED IF HERE COUNT TYPE ." isn't unique " THEN DROP HERE ELSE BL WORD THEN CURRENT @ HASH DUP @ ( Stack: cfa lfa tha prev) HERE 2- ROT ! ( Stack: cfa lfa prev ) SWAP ! ( Resolve link field, Stack: cfa ) HERE DUP C@ WIDTH @ MIN 1+ ALLOT ALIGN 128 SWAP CSET 128 HERE 1- CSET ( Delimiter Bits ) ; : CREATE (S -- ) HEADER COMPILE [ [FORTH] ASSEMBLER DOCREATE , META ] ; \ Extensible Layer Defining Words 04OCT83HHL: !CSP (S -- ) SP@ CSP ! ; : ?CSP (S -- ) SP@ CSP @ <> ABORT" Stack Changed" ; : HIDE (S -- ) LAST @ DUP N>LINK @ SWAP CURRENT @ HASH ! ; : REVEAL (S -- ) LAST @ DUP N>LINK SWAP CURRENT @ HASH ! ; : (;USES) (S -- ) R> @ LAST @ NAME> ! ; VOCABULARY ASSEMBLER : ;USES (S -- ) ?CSP COMPILE (;USES) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE : (;CODE) (S -- ) R> LAST @ NAME> ! ; : ;CODE (S -- ) ?CSP COMPILE (;CODE) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE : DOES> (S -- ) COMPILE (;CODE) 232 ( CALL ) C, [ [FORTH] ASSEMBLER DODOES META ] LITERAL HERE 2+ - , ; IMMEDIATE \ Extensible Layer Defining Words 27Sep83map: [ (S -- ) STATE OFF ; IMMEDIATE : ] (S -- ) STATE ON BEGIN ?STACK DEFINED DUP IF 0> IF EXECUTE ELSE , THEN ELSE DROP NUMBER DOUBLE? IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN THEN TRUE DONE? UNTIL ; : : (S -- ) !CSP CURRENT @ CONTEXT ! CREATE HIDE ] ;USES NEST , : ; (S -- ) ?CSP COMPILE UNNEST REVEAL [COMPILE] [ ; IMMEDIATE \ Extensible Layer Defining Words 16Oct83map: RECURSIVE (S -- ) REVEAL ; IMMEDIATE : CONSTANT (S n -- ) CREATE , ;USES DOCONSTANT , : VARIABLE (S -- ) CREATE 0 , ;USES DOCREATE , : DEFER CREATE ['] CRASH , ;USES DODEFER , DODEFER RESOLVES <DEFER> : VOCABULARY (S -- ) CREATE ( Threads ) #THREADS 0 DO 0 , LOOP HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; RESOLVES <VOCABULARY> : DEFINITIONS (S -- ) CONTEXT @ CURRENT ! ; \ Extensible Layer Defining Words 07OCT83HHL: 2CONSTANT CREATE , , (S d# -- ) DOES> 2@ ; (S -- d# ) DROP : 2VARIABLE 0 0 2CONSTANT (S -- ) DOES> ; (S -- addr ) DROP VARIABLE AVOC : CODE (S -- ) CREATE HIDE HERE HERE 2- ! CONTEXT @ AVOC ! ASSEMBLER ; ASSEMBLER DEFINITIONS : END-CODE AVOC @ CONTEXT ! REVEAL ; FORTH DEFINITIONS META IN-META \ Extensible Layer Defining Words 07SEP83HHLVARIABLE #USER VOCABULARY USER USER DEFINITIONS : ALLOT (S n -- ) #USER +! ; : CREATE (S -- ) CREATE #USER @ , ;USES DOUSER-VARIABLE , : VARIABLE (S -- ) CREATE 2 ALLOT ; : DEFER (S -- ) VARIABLE ;USES DOUSER-DEFER , FORTH DEFINITIONS META IN-META \ Extensible Layer ReDefining Words 07SEP83HHL: >IS (S cfa -- data-address ) DUP @ DUP [ [FORTH] ASSEMBLER DOUSER-VARIABLE META ] LITERAL = SWAP DUP [ [FORTH] ASSEMBLER DOUSER-DEFER META ] LITERAL = SWAP DROP OR IF >BODY @ UP @ + ELSE >BODY THEN ; : (IS) (S cfa --- ) R@ @ >IS ! R> 2+ >R ; : IS (S cfa --- ) STATE @ IF COMPILE (IS) ELSE ' >IS ! THEN ; IMMEDIATE \ Initialization High Level 23OCT83HHL: RUN (S -- ) STATE @ IF ] STATE @ NOT IF INTERPRET THEN ELSE INTERPRET THEN ; : QUIT (S -- ) SP0 @ 'TIB ! BLK OFF [COMPILE] [ BEGIN RP0 @ RP! STATUS QUERY RUN STATE @ NOT IF ." OK" THEN AGAIN ; DEFER BOOT : WARM (S -- ) TRUE ABORT" Warm Start" ; : COLD (S -- ) BOOT QUIT ; \ Initialization High Level 05OCT83HHL1 CONSTANT INITIAL : OK (S -- ) INITIAL LOAD ; : START (S -- ) EMPTY-BUFFERS DEFAULT OK ; : BYE ( -- ) CR HERE 0 256 UM/MOD 1+ DECIMAL U. DROP ." Pages" 0 0 BDOS ; \ Initialization Low Level 11OCT83HHL[FORTH] ASSEMBLER HERE ORIGIN 6 + - ORIGIN 4 + !-T ( WARM ENTRY ) ASSEMBLER ' WARM >BODY # IP MOV NEXT HERE ORIGIN 3 + - ORIGIN 1+ !-T ( COLD ENTRY ) ASSEMBLER CS AX MOV AX DS MOV AX SS MOV AX ES MOV 6 #) AX MOV 0 # AL MOV AX ' LIMIT 2+ #) MOV #BUFFERS B/BUF * # AX SUB AX ' FIRST 2+ #) MOV >SIZE # AX SUB AX RP MOV RP0 # W MOV UP #) W ADD RP 0 [W] MOV 200 # AX SUB AX 'TIB #) MOV SP0 # W MOV UP #) W ADD AX 0 [W] MOV AX SP MOV ' COLD >BODY # IP MOV NEXT IN-META \ Initialize User Variables 16Oct83mapHERE UP !-T ( SET UP USER AREA ) 0 , ( TOS ) 0 , ( ENTRY ) 0 , ( LINK ) 0 , ( SP0 ) 0 , ( RP0 ) 0 , ( DP ) ( Must be patched later ) 0 , ( #OUT ) 0 , ( #LINE ) 0 , ( OFFSET ) 10 , ( BASE ) 0 , ( HLD ) 0 , ( FILE ) FALSE , ( PRINTING ) ' (EMIT) , ( EMIT ) \ Resident Tools 29Sep83map: DEPTH (S -- n ) SP@ SP0 @ SWAP - 2/ ; : .S (S -- ) DEPTH ?DUP IF 0 DO DEPTH I - 1- PICK 7 U.R SPACE LOOP ELSE ." Empty " THEN ; : .ID (S nfa -- ) DUP 1+ DUP C@ ROT C@ 31 AND 0 ?DO DUP 127 AND EMIT 128 AND IF ASCII _ 128 OR ELSE 1+ DUP C@ THEN LOOP 2DROP SPACE ; : DUMP (S addr len -- ) 0 DO CR DUP 6 .R SPACE 16 0 DO DUP C@ 3 .R 1+ LOOP 16 +LOOP DROP ; \ For Completeness 07OCT83HHL: RECURSE (S -- ) LAST @ NAME> , ; IMMEDIATE : OCTAL (S -- ) 8 BASE ! ; \ Resolve Forward References 07SEP83HHL ' (.") RESOLVES <(.")> ' (") RESOLVES <(")> ' (;CODE) RESOLVES <(;CODE)> ' (;USES) RESOLVES <(;USES)> ' (IS) RESOLVES <(IS)> ' (ABORT") RESOLVES <(ABORT")> [FORTH] ASSEMBLER DOCREATE META RESOLVES <VARIABLE> [FORTH] ASSEMBLER DOUSER-DEFER META RESOLVES <USER-DEFER> [FORTH] ASSEMBLER DOUSER-VARIABLE META RESOLVES <USER-VARIABLE> \ Resolve Forward References 16Oct83map' SWAP RESOLVES SWAP ' + RESOLVES + ' OVER RESOLVES OVER ' DEFINITIONS RESOLVES DEFINITIONS ' [ RESOLVES [ ' 2+ RESOLVES 2+ ' 1+ RESOLVES 1+ ' 2* RESOLVES 2* ' 2DUP RESOLVES 2DUP ' ?MISSING RESOLVES ?MISSING ' QUIT RESOLVES QUIT ' RUN RESOLVES RUN ' >IS RESOLVES >IS ' (?ERROR) IS ?ERROR \ Initialize DEFER words 16Oct83map ' (LOAD) IS LOAD ' CRLF IS CR ' (KEY?) IS KEY? ' (KEY) IS KEY ' FILE-READ IS READ-BLOCK ' FILE-WRITE IS WRITE-BLOCK ' NOOP IS WHERE ' CR IS STATUS ' (?ERROR) IS ?ERROR ' (SOURCE) IS SOURCE ' NOOP IS BOOT ' (NUMBER) IS NUMBER ' (CHAR) IS CHAR ' (DEL-IN) IS DEL-IN \ Initialize Variables 01Oct83map' FORTH >BODY CURRENT !-T ' FORTH >BODY CONTEXT !-T ' CC1 >BODY CC !-T HERE-T DP UP @-T + !-T ( INIT USER DP ) #USER-T @ #USER !-T ( INIT USER VAR COUNT ) FALSE CAPS !-T ( SET TO RESPECT CASE ) TRUE WARNING !-T ( SET TO ISSUE WARNINGS ) 31 WIDTH !-T ( 31 CHARACTER NAMES ) VOC-LINK-T @ VOC-LINK !-T ( INIT VOC-LINK ) \ Further Instructions 11OCT83HHLEXIT ******************************************************************* ****** Thus we have created a hopefully running ****** Forth system for the 8086. After this file ****** has been compiled, it is saved as a CMD file ****** called KERNEL86.CMD on the disk. To generate ****** a system you must now leave the Meta Compiler ****** and fire up KERNEL with the file EXTEND86.BLK ****** on the execute line. Be sure to prefix a B: ****** if necessary. ( KERNEL86 EXTEND86.BLK ) ****** Once you have fired it up, type START and it ****** will compile the applications. Good Luck. ****** ******************************************************************* \ Load Screen for Pre-Compile 10MAR83HHLMeta Compiling is a term to describe the process of regeneratinga Forth system by compiling itself. It is similar in idea to the ordinary notion of compiling in Forth, but has some important differences. First the code that is generated by the Meta Compiler is generally not immediately executable. This maybe for a variety of reasons, such as that the object code generated physically resides at a different address from where it must be to execute correctly. Also, it is possible through Meta Compilation to generate a Forth System for a totally different CPU than the one the Meta Compiler is running on. In such a case, the object code of course is not executable on the Host System. This Screen is the load screen for the Meta Compiler itself. The purpose of this section of the Meta Compiler is to compile Code Words correctly. \ Target System Setup 12Oct83map Make Room for HOST definitions Set up the address where Target Compiled Code begins Set up the address where the Target Headers begin Set up the HOST address where Target Image resides Load the Source Screens that define the System For MS-DOS, use lines 10 and 11 instead of line 12. Save the System as a CP/M file, ready to be executed \ Vocabulary Helpers 07SEP83HHL META The Meta Compiler Environment, many redefintions DP-T The dictionary Pointer while meta compiling [FORTH] For convenience, an immediate version [META] For convenience, an immediate version SWITCH Exchange the saved values of CONTEXT and CURRENT with themselves. This should be used in pairs, and is only really meaningful in the second occurance. Its purpose is to save and restore the CONTEXT and CURRENT vocabularies. Following the first occurance you should invoke a vocabulary and perhaps DEFINITIONS. \ Memory Access Words 10MAR83HHLTARGET-ORIGIN The Offset where the Target Image resides THERE Map a Target address to a Host address C@-T Fetch a byte at the given Target address @-T Fetch a word at the given Target address C!-T Store a byte at the given Target address !-T Store a word at the given Target address HERE-T Target address of next available dictionary byteALLOT-T Allocate more space in the Target dictionary C,-T Add a byte to the Target dictionary ,-T Add a word to the Target dictionary S,-T Add a string to the Target dictionary \ Define Symbol Table Vocabularies 07SEP83HHLTARGET The symbol table for Target definitions TRANSITION Holds special case compiling words, like ." and [ FORWARD Holds all forward references, not neccessary but niceUSER Holds USER version of defining words We add all of the vocabulary names to the ONLY vocabulary so that they are always accessible. This is mainly a convienence during debugging, when something fails and we need to look at different words in various vocabularies to figure out what is going on. Now we are guaranteed that we can reference all of the vocabularies inside META without standing on our heads. \ Define Meta Branching Constructs 11OCT83HHL?>MARK Set up for a forward branch. ?>RESOLVE Resolve a forward branch. ?<MARK Set up for a backwards branch. ?<RESOLVE Resolve a backwards branch. \ 8086 Meta Assembler 11OCT83HHLM?>MARK Set up for a forward branch. M?>RESOLVE Resolve a forward branch. M?<MARK Set up for a backwards branch. M?<RESOLVE Resolve a backwards branch. Because the following words are DEFERRED in the ASSEMBLER, we can redefine them in the Meta Compiler and use the exact same assembler we were using before. This is very convenient since it saves time and space. In fact, because the assembling portions of the asssember are deferred, we can use this same Assembler to do target assembly at a totally different origin. Since Assember branches are 1 byte on the 8086, we need to have different MARK and RESOLVE words for hi level branches and machine language branches. \ Meta Compiler Vocabulary Manipulators 02AUG83HHLMAKE-CODE Take the code field pointed to and compile it in the Target LABEL Remember the current Target address and assign it a name. IN-TARGET Search only the Symbol Table. IN-TRANSITION Search TRANSITON TARGET and FORWARD in that order. IN-META The normal environment when interpreting in Meta. IN-FORWARD Used when a word is undefined and compiled on the fly. \ Meta Compiler Forward Reference Linking 10MAR83HHLLINK-BACKWARDS Create a linked list of unresolved forward references. RESOLVED? Return non-zero if the word is already resolved. FORWARD-CODE If a forward reference is resolved, compile code else link itFORWARD: Defines an explicit forward reference. Initializes it to be unresolved. \ Create Headers in Target Image 16Oct83mapWIDTH The maximum length of the names in the Target LAST-T Points to the name of the most recent Target word CONTEXT-T Not really used, unless DEFINITIONS follows CURRENT-T Points to the Target vocabularies thread pointers. HASH Each name is linked into 1 of 4 threads to improve speed HEADER Create a header in the Target Dictionary. If WIDTH is zero, then no heads are created. HEADER in the Meta Compiler behaves the same as CREATE does in ordinary Forth. It makes a header out of the next word in the input stream, and fixes up all of the appropriate pointers to link it into the Target Dictionary. The top 4 bits of the VIEW field are a file number. "4096 +" sets the file number to one, which will mean META80.BLK. \ Meta Compiler Create Target Image 10MAR83HHLTARGET-CREATE Create a Target Header and an entry in the symbol table. It is initialized to already resolved, so it compiles itself. RECREATE Same as TARGET-CREATE, but don't advance the input stream. CODE Set up for a low level word. CFA @ = PFA ie ITC. C; Terminate a low level word. Not required but tidy to have. \ Force compilation of target & forward words 10MAR83HHL'T Look up the next word in the input stream only in the TARGET vocabulary, disturbing nothing else. [TARGET] Force compilation of a TARGET word, regardless of CONTEXT 'F Look up the next word in the input stream only in the FORWARD vocabulary, disturbing nothing else. [FORWARD] Force compilation of a FORWARD word, regardless of CONTEXT \ Meta Compiler Branching & Defining Words 10MAR83HHLT: Used for special case compiling words. TRANSITION is normally searched before TARGET. Acts just like a : def. T; Terminate a word defined by T: DIGIT? Returns true if the character is a digit in current base. PUNCT? Returns true if the character is a valid puntucation character for numbers, such as leading - or decimal point. NUMERIC? Returns true if the string is a valid number in the current base. Note that a special test is made to make sure at least one digit is present. This prevents - from being a number. \ Meta Compiler Transition Words 10MAR83HHL( Inherit ( from host for comments. (S Inherit (S from host for comments. \ Inherit \ from host for comments. STRING,-T Scan the input stream for a " delimited text and compile it. <(.")> Run time forward reference for code compiled by ." ." Compile the unknown run time code, followed by the string. <(")> Run time forward reference for code compiled by " " Compile unknown run time code, followed by string. <(ABORT")> Run time forward ref. for code compiled by ABORT" ABORT" Compile the unknown run time code, followed by the string. \ Meta Compiler Transition Words 06SEP83HHL<VARIABLE> Forward reference for run time of CREATE & VARIABLECREATE Create a target word whose run time is the run time for VARIABLE. Also create a host word to rreturn Target Here addrVARIABLE Make a variable in the Target Image. <DEFER> Forward reference for run time of DEFER DEFER An execution vector in the Target System. \ Meta Compiler Transition Words 06SEP83HHL#USER-T Counts the number of user variables defined so far. ALLOT Allocate space in the USER area. <USER-VARIABLE> Forward reference for run time of USER vars. VARIABLE Create a User variable, which is task local. <USER-DEFER> Forward reference for run time of USER vectorsDEFER Create a task local execution vector. \ Meta Compiler Transition Words 10MAR83HHLVOC-LINK-T Links defined Vocabularies together. <VOCABULARY> Forward reference for run time of VOCABULARY VOCABULARY Create a target word that behaves like a vocabulary. Only one target vocabulary can contain definitions in this meta compiler, but several can be defined. IMMEDIATE If heads are compiled, flip the Target IMMEDIATE bit. \ Meta Compiler Transition Words 06SEP83HHL<(;USES)> Forward reference for code compiled by ;USES STATE-T True if compiling inside : def. False if outside. ;USES This is a new syntax that can be used to compile a code field whose code already exists. Similar to ;CODE [COMPILE] Compile a TARGET word rather than execute its TRANSITION counterpart. <(IS)> Forward reference for run time of IS IS Compiles the unknown code field of <(IS)> IS The Meta Version of IS actually does the patch. ALIGN Makes the dictionary even. NOOP on 8080's EVEN Make the number even. NOOP on 8080's \ Display an unformatted Symbol Table 10MAR83HHL.SYMBOLS Print a primitive unformatted symbol table on the display. This is very useful if you ever need to debug with DDT, you have no idea where the addresses are. You can make it pretty if you like. \ Meta Compiler Resolve Forward References 10MAR83HHL.UNRESOLVED Display all the words in the FORWARD vocabulary that have not already been resolved. You had better resolve them before saving a system, or else they will surely crash when you execute them. FIND-UNRESOLVED Search for a word in the FORWARD vocabulary and return statusRESOLVE Run through the linked list of forward reference and resolve each of the with the given address. RESOLVES The user interface for resolving forward references. Used as follows: ' resolution-name RESOLVES forward-name \ Interpretive words for Meta 02AUG83HHLH: Save a version of old : for later. Will be redefined. ' How ' should behave during Target Compilation. , How , should behave during Target Compilation. C, How C, should behave during Target Compilation. HERE How HERE should behave during Target Compilation. ALLOT How ALLOT should behave during Target Compilation. DEFINITIONS How DEFINITIONS should behave when interpreted. \ Declare the Forward References 27Sep83map]] We will need the FORTH version of ] quite often. [[ The same is true for [[. DEFINIITONS To avoid finding DEFINITIONS in the ONLY vocabulary[ To avoid finding [ in the TRANSITION vocabulary \ Boot up Vectors and NEXT Interpreter 02AUG83HHL The first 8 bytes in the system are vectors to the Cold and Warmstart entries. You can freely jump to them in code anytime. The DPUSH and HPUSH labels are space savers. We jump to them in several CODE words when we want to push their contents on theParameter Stack. >NEXT is where all the action is. It is the guts of the Forth Virtual Machine. It must advance the interpretive pointer held in the IP register pair and jump indirect to what it points to. We define a few macros here to make our life a little easier later. Using NEXT as a macro allows us to put it inline later. \ Run Time Code for Defining Words 23JUL83HHLNEST The runtime code for : It pushs the current IP onto the return stack and sets the IP to point to the parameter field of the word being executed. EXIT Pop an entry off the return stack and place it into the Interpretive Pointer. Terminates a Hi Level definition. UNNEST Same as exit. Compiled by ; to help decompiling. DODOES The runtime portion of defining words. First it pushes the IP onto the return stack and then it pushes the BODY address of the word being executed onto the parameter stack. DOCREATE Leave a pointer to its own parameter field on the stack. This is also the runtime for variable. \ Run Time Code for Defining Words 11OCT83HHLUP Holds a pointer to the current USER area. ( multitasking ) DOCONSTANT The run time code for CONSTANT. It takes the contents of the parameter field and pushes it onto the stack.DOUSER The run time code for USER variables. Places a pointer to the current version of this variable on the stack. Needed for multitasking. (LIT) The runtime code for literals. Pushes the following two bytes onto the parameter stack and moves the IP over them. It is compiled by the word LITERAL. \ Meta Defining Words 10MAR83HHLLITERAL Now that code field of (LIT) is known, define LITERAL DLITERAL Both LITERAL and DLITERAL are TRANSITION words, ie IMMEDIATE ASCII Compile the next character as a literal. ['] Compile the code field of the next word as a literal. CONSTANT Define a CONSTANT in the Target. We also save its value in META for use during interpretation. \ Identify numbers and forward References 02AUG83HHL<(;CODE)> Forward reference for code to patch code field. DOES> Compile the code field for (;CODE) and a CALL instruction to the run time for DOES, called DODOES. NUMERIC Make a number out of this word and compile it as either a single or double precision literal. NUMERIC is only called if the word is known to be a number. UNDEFINED Creates a forward reference "on the fly". The symbol is kept in the FORWARD vocabulary and it is initialized to unresolved. When executed it either compiles itself or links into a backwards pointing chain of forward references. \ Meta Compiler Compiling Loop 10MAR83HHLT-IN Needed to save a pointer into the input stream for later.] Start compiling into the TARGET system. Always search TRANSITION before TARGET for immediate words. If word is found, execute it. It must compile itself. If word is not found, convert it to a number if it is numeric, otherwise it is a forward reference. [ Sets STATE-T to false to exit the Meta Compiling loop above. ; Compile the code field of UNNEST and terminate compilation : Create a target word and set its code field to NEST. \ Run Time Code for Control Structures 05MAR83HHLBRANCH Performs an unconditional branch. Notice that we are using absolute addresses insead of relative ones. (fast) ?BRANCH Performs a conditional branch. If the top of the parameter stack in True, take the branch. If not, skip over the branch address which is inline. \ Meta Compiler Branching Words 10MAR83HHLThese are the META versions of the structured conditionals found in FORTH. They must compile the correct run time branch instruction, and then Mark and Resolve either forward or backward branches. These are very analogous to the regular conditionals in Forth. Since they are in the TRANSITION vocabulary, which is searched before the TARGET vocabulary, they will be executed instead of the TARGET versions of these words which are defined much later. \ Run Time Code for Control Structures 11OCT83HHL(LOOP) the runtime procedure for LOOP. Branches back to the beginning of the loop if there are more iterations to do. Otherwise it exits. The loop counter is incremented. (+LOOP) Increment the loop counter by the value on the stack and decide whether or not to loop again. \ Run Time Code for Control Structures 28AUG83HHL (DO) The runtime code compiled by DO. Pushes the inline address onto the return stack along with values needed by (LOOP). (?DO) The runtime code compiled by ?DO. The difference between ?DO and DO is that ?DO will not perform any iterations if the initial index is equal to the final index. BOUNDS Given address and length, make it ok for DO ... LOOP. \ Meta compiler Branching & Looping 10MAR83HHLThese are again the TRANSITION versions of the immediate words for looping. They compile the correct run time code and then Mark and Resolve the various branches. \ Execution Control 06SEP83HHL>NEXT The address of the inner interpreter. EXECUTE the word whose code field is on the stack. Very useful for passing executable routines to procedures!!! PERFORM the word whose code field is stored at the address pointed to by the number on the stack. Same as @ EXECUTE DO-DEFER The runtime code for deferred words. Fetches the code field and executes it. DOUSER-DEFER The runtime code for User deferred words. These are identical to regular deferred words except that each task has its own version. GO Execute code at the given address. NOOP One of the most useful words in Forth. Does nothing. PAUSE Used by the Multitasker to switch tasks. \ Execution Control 11OCT83HHLI returns the current loop index. It now requires a little more calculation to compute it than in FIG Forth but the tradeoff is a much faster (LOOP). The loop index is stored on the Return Stack. J returns the loop index of the inner loop in nested DO .. LOOPs. (LEAVE) Does an immediate exit of a DO ... LOOP structure. Unlike FIG Forth which waits until the next LOOP is executed. (?LEAVE) Leaves if the flag on the stack is true. Continues if not. LEAVE I have to do this to be 83-Standard. ?LEAVE I have to do this to be consistent. Sad but true. \ 16 and 8 bit Memory Operations 05MAR83HHL@ Fetch a 16 bit value from addr. ! Store a 16 bit value at addr. C@ Fetch an 8 bit value from addr. C! Store an 8 bit value at addr. \ Block Move Memory Operations 05MAR83HHLCMOVE Move a set of bytes from the from address to the to address. The number of bytes to be moved is count. The bytes are moved from low address to high address, so overlap is possible and in fact sometimes desired. CMOVE> The same as CMOVE above except that bytes are moved in the opposite direction, ie from high addresses to low addresses. \ 16 bit Stack Operations 02AUG83HHLSP@ Return the address of the next entry on the parameter stackSP! ( Warning, this is different from FIG Forth ) Sets the parameter stack pointer to the specified value. RP@ Return the address of the next entry on the return stack. RP! ( Warning, this is different from FIG Forth ) Sets the return stack pointer to the specified value. \ 16 bit Stack Operations 05MAR83HHLDROP Throw away the top element of the stack. DUP Duplicate the top element of the stack. SWAP Exchange the top two elements on the stack. OVER Copy the second element to the top. \ 16 bit Stack Operations 11MAR83HHLTUCK Tuck the first element under the second one. NIP Drop the second element from the stack. ROT Rotate the top three element, bringing the third to the top. -ROT The inverse of ROT. Rotates the top element to third place. FLIP Exhange the hi and low halves of a word. ?DUP Duplicate the top of the stack if it is non-zero. \ 16 bit Stack Operations 26Sep83mapR> Pops a value off of the return stack and pushes it onto the parameter stack. It is dangerous to use this randomly! >R Pops a value off of the parameter stack and pushes it onto return stack. It is dangerous to use this randomly! R@ Copies the value on the return stack to the parameter stack. PICK Reaches into the stack and grabs an element, copying it to the top of the stack. For example, if the stack has 1 2 3 Then 0 PICK is 3, 1 PICK is 2, and 2 PICK is 1. ROLL Similar to SHAKE and RATTLE. Should be avoided. 1 ROLL is SWAP, 2 ROLL is ROT, etc. ROLL can be useful, but it is slow. \ 16 bit Logical Operations 11OCT83HHLAND Returns the bitwise AND of n1 and n2 on the stack. OR Returns the bitwise OR of n1 and n2 on the stack. XOR Returns the bitwise Exclusive Or of n1 and n2 on the stack. NOT Does a ones complement of the top. Equivalent to -1 XOR. TRUE FALSE Constants for clarity. \ Logical Operations 16Oct83mapCSET Set the contents of addr so that the bits that are 1 in n are also 1 in addr. Equivalent to DUP C@ ROT OR SWAP C! CRESET Set the contents of addr so the the bits that are 1 in n are zero in addr. Equivalent to DUP C@ ROT NOT AND SWAP C! CTOGGLE Flip the bits in addr by the value n. Equivalent to DUP C@ ROT XOR SWAP C! ON Set the contents of addr to TRUE OFF Set the contents of addr to FALSE \ 16 bit Arithmetic Operations 05MAR83HHL+ Add the top two numbers on the stack and return the result. NEGATE Turn the number into its negative. A twos complement op. - Subtracts n2 from n1 leaving the result on the stack. ABS Return the absolute value of the 16 bit integer on the stack +! Increment the value at addr by n. This is equivalent to the following: DUP @ ROT + SWAP ! but much faster. 0 1 Frequently used constants 2 3 Are faster and more code efficient. \ 16 bit Arithmetic Operations 26Sep83map2* Double the number on the Stack. 2/ Shift the number on the stack right one bit. Equivalent to division by 2 for positive numbers. U2/ 16 bit logical right shift. 8* Multiply the top of the stack by 8. 1+ Increment the top of the stack by one. 2+ Increment the top of the stack by two. 1- Decrement the top of the stack by one. 2- Decrement the top of the stack by two. \ 16 bit Arithmetic Operations Unsigned Multiply 11OCT83HHLYou could write a whole book about multiplication and division, and in fact Knuth did. Suffice it to say that UM* is the basic multiplication primitive in Forth. It takes two unsigned 16 bitintegers and returns an unsigned 32 bit result. All other multiplication functions are derived from this primitive one. U*D is a synonym for UM* \ 16 bit Arithmetic Operations Unsigned Divide 05MAR83HHLUM/MOD This is the division primitive in Forth. All other division operations are derived from it. It takes a double number, d1, and divides by by a single number n1. It leaves a remainder and a quotient on the stack. For a clearer understanding of arithmetic consult Knuth Volume 2 on Seminumerical Algorithms. \ 16 bit Comparison Operations 11OCT83HHLYES Push a true onto the stack. A code saver. NO Push a flase onto the stack. A code saver. 0= Returns True if top is zero, False otherwise. 0< Returns true if top is negative, ie sign bit is on. 0> Returns true if top is positive. 0<> Returns true if the top is non-zero, False otherwise. = Returns true if the two elements on the stack are equal, <> Returns true if the two element are not equal, else false. ?NEGATE Negate the second element if the top is negative. \ 16 bit Comparison Operations 05OCT83HHLYES To make sure we are within 128 bytes U< Unsigned comparison of the top two elements. Be sure to use U< or U> whenever comparing addresses! U> Compare the top two elements on the stack as unsigned integers. True if n1 > n2 unsigned. < Compare the top two elements on the stack as signed integers and return true if n1 < n2. > Compare the top two elements on the stack as signed integers and return true if n1 > n2. MIN Return the minimum of n1 and n2 MAX Return the maximum of n1 and n2 BETWEEN Return true if min <= n1 <= max, otherwise false. WITHIN Return true if min <= n1 < max, otherwise false. \ 32 bit Memory Operations 09MAR83HHL2@ Fetch a 32 bit value from addr. 2! Store a 32 bit value at addr. \ 32 bit Memory and Stack Operations 26Sep83map2DROP Drop the top two elements of the stack. 2DUP Duplicate the top two elements of the stack. 2SWAP Swap the top two pairs of numbers on the stack. You can use this operator to swap two 32 bit integers and preserve their meaning as double numbers. 2OVER Copy the second pair of numbers over the top pair. Behaves like 2SWAP for 32 bit integers. 3DUP Duplicate the top three elements of the stack. 4DUP Duplicate the top four elements of the stack. 2ROT rotates top three double numbers. \ 32 bit Arithmetic Operations 05MAR83HHLD+ Add the two double precision numbers on the stack and return the result as a double precision number. DNEGATE Same as NEGATE except for double precision numbers. S>D Take a single precision number and make it double precision by extending the sign bit to the upper half. DABS Return the absolute value of the 32 bit integer on the stack \ 32 bit Arithmetic Operations 01Oct83mapD2/ 32 bit arithmetic right shift. Equivalent to divide by 2. D- Subtract the two double precision numbers. ?DNEGATE Negate the double number if the top is negative. \ 32 bit Comparison Operations 11OCT83HHLD0= Compare the top double number to zero. True if d = 0 D= Compare the top two double numbers. True if d1 = d2 DU< Performs unsigned comparison of two double numbers. D< Compare the top two double numbers. True if d1 < d2 D> Compare the top two double numbers. True if d1 > d2 DMIN Return the lesser of the top two double numbers. DMAX Return the greater of the the top two double numbers. \ Mixed Mode Arithmetic 27Sep83mapThis does all the arithmetic you could possibly want and even more. I can never remember exactly what the order of the arguments is for any of these, except maybe * / and MOD, so I suggest you just try it when you are in doubt. That is one of the nice things about having an interpreter around, you can ask it questions anytime and it will tell you the answer. *D multiplys two singles and leaves a double. M/MOD divides a double by a single, leaving a single quotient and a single remainder. Division is floored. MU/MOD divides a double by a single, leaving a double quotient and a single remainder. Division is floored. \ 16 bit multiply and divide 27Sep83map */ is a particularly useful operator, as it allows you to do accurate arithmetic on fractional quantities. Think of it as multiplying n1 by the fraction n2/n3. The intermediate result is kept to full accuracy. Notice that this is not the same as * followed by /. See Starting Forth for more examples. \ Task Dependant USER Variables 16Oct83map TOS Saved during Task switching. ENTRY Jumped to during multitasking. LINK Points to next task in the circular queue SP0 Empty parameter stack for this task. RP0 Empty return stack for this task. DP Size of dictionary. Next available location. #OUT Number of characters sent since last CR. #LINE Number of CR's sent since last page. OFFSET Added to all block references. BASE The current numeric base for number input output. HLD Points to a converted character during numeric output. FILE Allows printing of one file while editing another. PRINTING indicates whether printing is enabled. EMIT Sends a character to the output device. \ System VARIABLEs 16Oct83map return from user to meta definitions SCR Holds the screen number last listed or edited. PRIOR Points to the last vocabulary that was searched. DPL The decimal point location for number input. WARNING Checked by WARN for duplicate warnings. R# The cursor position during editing. HLD Points to a converted character during numeric output. LAST Points to the name of the most recently CREATEd word. CSP Used for compile time error checking. CURRENT New words are added to the CURRENT vocabulary. #VOCS The number of elements in the search order array. CONTEXT The array specifying the search order. \ System Variables 02AUG83HHL'TIB Points to characters entered by user. WIDTH Number of characters to keep in name field. VOC-LINK Points to the most recently defined vocabulary. BLK If non-zero, the block number we are interpreting. >IN Number of characters interpreted so far. SPAN Number of characters input by EXPECT. #TIB Used by WORD, when interpreting from the terminal. END? True if input stream exhausted, else false. \ Devices Strings 02AUG83HHLBL BS BELL Names for BLank, BackSpace, and BELL CAPS If true, then convert names to upper case FILL FILL the string starting at start-addr for count bytes with the character char. Both BLANK and ERASE are special cases of FILL. ERASE Fill the string with zeros BLANK Fill the string with blanks COUNT Given the address on the stack, returns the address plus one and the byte at that address. Useful for strings. LENGTH Given the address on the stack, returns the address plus two and the two byte contents of the address. MOVE Move the specified bytes without overlapping. \ Devices Strings 07SEP83HHL>UPPER Convert the Char in A to upper Case UPPER Take the string at the specified address and convert it to upper case. It converts thr staring in place, so be sure to make a copy of the original if you need to use it later HERE Return the address of the top of the dictionary PAD Floating Temporary Storage area. -TRAILING Return the address and length of the given string ignoring trailing blanks. \ Devices Strings 26Sep83mapCOMP This performs a string compare. If the two strings are equal, then COMPARE returns 0. If the two strings differ, then COMPARE returns -1 or +1. -1 is returned if string 1 is less than string 2. +1 is returned if string 1 is greater than string 2. All comparisons are relative to ASCII order. The code on this screen handles the case when upper/lower case is deemed significant. Thus lower case a does not match upper case A. \ Devices Strings 26Sep83mapCAPS-COMP The code on this screen handles the case where case is not significant. Each character is converted to upper case before the comparison is made. Thus, lower case a and upper case A are considered identical. COMPARE Performs a string compare. If CAPS is true, characters from both strings are converted to upper case before comparing. \ Devices Terminal IO via CP/M BIOS 27Sep83mapBDOS Load up the registers and do a CP/M system call return the result placed in the A register on the stack. (KEY?) Returns true if the user pressed a key, otherwise false. (KEY) Pauses until a key is ready, and returns it on the stack. (EMIT) The default value of the DEFERRED word EMIT. Sends the character to the terminal. (PRINT) The value of the DEFERRED word EMIT when you want to send a character to the printer. \ Devices Terminal Output 27Sep83mapKEY? Usually set to (KEY?), to sense keyboard status. KEY Usually set to (KEY) to get a character from the user. CR Typically set to CRLF, above. (PEMIT) sends a character to both the console and the printer. CRLF Sends a carriage return line feed sequence. TYPE Display the given string on the terminal. SPACE Send a space to the terminal SPACES Send a set of spaces to the terminal BACKSPACES Send a set of Backspaces to the terminal. BEEP Ring the bell on the terminal \ Devices System Dependent Control Characters 29Sep83mapBS-IN If at beginning of line, beep, otherwise back up and erase 1.DEL-IN If at beginning of line, beep, otherwise back up 1. BACK-UP Wipe out the current line by overwriting it with spaces. RES-IN Reset the system to a relatively clean state. P-IN Toggle the printer on or off \ Devices Terminal Input 11OCT83HHLCR-IN Finish input and remember the number of chars in SPAN (CHAR) Process an ordinary character by appending it to the buffer. CHAR is usually (CHAR). Executed for most characters. DEL-IN is usually (DEL-IN). Executed for delete characters. CC Points to current control character table. CC1 Handle each control character as a special case. This generates an execution array which is indexed into by EXPECT to do the right thing when it receives a control character. \ Devices Terminal Input 29Sep83mapEXPECT Get a string from the terminal and place it in the buffer provided. Performs a certain amount of line editing. Saves the number of characters input in the Variable SPAN. Processes control characters per the array pointed to by CC. TIB Leaves address of text input buffer. QUERY Get more input from the user and place it at TIB. \ Devices BLOCK I/O 27Sep83mapThese variables are used by the BLOCK IO part of the system. Unlike FIG Forth the buffers are managed in a true least recently used scheme. The are maintained in memory as an array of 8 byte entries, whose format is defined at left. Whenever a BLOCK is referenced its pointer is moved to the head of the array, so the most recently used buffer is first. Thus multiple references are very fast. Also we have eliminated the need for a null at the end of each BLOCK buffer so that the size of a buffer is now exactly 1024 bytes. The format of entries in the buffer-pointer array is: 0-1 is Block Number 2-3 is Pointer to File 4-5 is Address of Buffer 6-7 is Update Flag BUFFER# Return the address the the nth buffer pointer. >END Return a pointer to just past the last buffer packet. \ Devices BLOCK I/O 07OCT83HHLFCB1 The default File Control Block CLR-FCB Initialize the current FCB. RECORD# Pointer to the current Ramdom Record MAXREC# Pointer to the largest record allowed CAPACITY The number of blocks in the current file BADREC# Remember where we went wrong IN-FILE? Makes sure that the current Random Record is within Range. Issues error message if it isn't. VIEW# Contains the file number for viewing. SET-DRIVE CP/M system call to set current drive SET-DMA CP/M system call to set dma address REC-READ Do a Random Access read REC-WRITE Do a Random Access write \ Devices BLOCK I/O 29Sep83mapREAD-BLOCK vector for reading blocks. WRITE-BLOCK vector for writing blocks. SET-IO common set-up for file reads and writes. FILE-READ read 1024 bytes from a file. FILE-WRITE write 1024 bytes to a file. FILE-IO set block read and writes to use files. \ Devices BLOCK I/O 02AUG83HHLLATEST? For increased performance we first check to see if the block we want is the very first one in the list. If it is return the buffer address and false, and exit from the word that called us, namely ABSENT?. Otherwise we return as though nothing had happened. ABSENT? Search through the block/buffer list for a match. If it is found, bring the block packet to the top of the list and return a false flag and the address of the buffer. If the block is not found, return true, indicating it is absent, and the second parameter is garbage. \ Devices BLOCK I/O 29Sep83mapUPDATE Mark the most recently used buffer as modified. DISCARD Mark the most recently used buffer as unmodified. MISSING Discards the least recently used buffer, potentially writing it back to disk if it was modified, and moves all of the buffer pointers down by one, making the first one available for the new block. It then marks the newly available buffer as containing the new block. BUFFER Returns the address of the buffer corresponding to block n. No disk read is performed. BLOCK Returns the address of a 1024 byte buffer corresponding to the block number given. Reads disk if necessary. \ Devices BLOCK I/O 29Sep83mapEMPTY-BUFFERS First wipe out the data in the buffers. Next initialize the buffer pointers to point to the right addresses in memory and set all of the update flags to unmodified. SAVE-BUFFERS Write back all of the updated buffers to disk, and mark them as unmodified. Use this whenever you are worried about crashing or losing data. FLUSH Save and empties the buffers. Used for changing disks. The phrase " 0 BLOCK DROP " is a kludge for CP/M. Some systems do extra buffering in the BIOS, and you must access a new block to be sure the old one is actually written to disk\ Devices BLOCK I/O 27Sep83mapFILE-SIZE Return the size of the file in records. CPM-ERR? Returns true if a CP/M error occurred OPEN-FILE Open the current file and tell user if you can't. Determine the size of the file and save it for error check. MORE Extend the size of the current file by n Blocks. CPM-FCB The address where CP/M puts a parsed FCB DEFAULT Opens the default file per the execute line. Move the already parsed file control block into FCB1, and open the file. This does nothing if no file was given. (LOAD) Load the screen number that is on the stack. The input stream is diverted from the terminal to the disk. LOAD Interpret a screen as if it were type in . \ Interactive Layer Number Input 04OCT83HHLDIGIT Returns a flag indicating whether or not the character is a valid digit in the given base. If so, returns converted value and true, otherwise returns char and false. DOUBLE? Returns non-zero if period was encountered. CONVERT Starting with the unsigned double number ud1 and the string at adr1, convert the string to a number in the current base. Leave result and address of unconvertable digit on stack. \ Interactive Layer Number Input 07OCT83HHL(NUMBER?) Given a string containing at least one digit, convert it to a number. NUMBER? Convert the count delimited string at addr to a double number. NUMBER? takes into account a leading minus sign, and stores a pointer to the last delimiter in DPL. The string must end with a blank. Leaves a true flag if successful. (NUMBER) Convert the count delimited string at addr to a double number. (NUMBER) takes into account a leading minus sign, and stores a pointer to the last period in DPL. Note the string must end with a blank or an error message is issued. NUMBER Convert a string to a number. Normally (NUMBER) \ Interactive Layer Number Output 05MAR83HHLHOLD Save the char for numeric output later. <# Start numeric conversion. #> Terminate numeric conversion. SIGN If n1 is negative insert a minus sign into the string. # Convert a single digit in the current base. #S Convert a number until it is finished. HEX All subsequent numeric IO will be in Hexadecimal DECIMAL All subsequent numeric IO will be in Decimal \ Interactive Layer Number Output 02AUG83HHL(U.) Convert an unsigned 16 bit number to a string. U. Output as an unsigned single number with trailing space. U.R Output as an unsigned single number right justified. (.) Convert a signed 16 bit number to a string. . Output as a signed single number with a trailing space. .R Output as a signed single number right justified. (UD.) Convert an unsigned double number to a string. UD. Output as an unsigned double number with a trailing spaceUD.R Output as an unsigned double number right justified. (D.) Convert a signed double number to a string. D. Output as a signed double number with a trailing space. D.R Output as a signed double number right justified. \ Interactive Layer Parsing 30Sep83mapSKIP Given the address and length of a string, and a character to look for, run through the string while we continue to find the character. Leave the address of the mismatch and the length of the remaining string. SCAN Given the address and length of a string, and a character to look for, run through the string until we find the character. Leave the address of the match and the length of the remaining string. \ Interactive Layer Parsing 01Oct83map/STRING Index into the string by n. Returns addr+n and len-n. PLACE Move the characters at from to to with a preceding length byte of len. (SOURCE) Returns the string to be scanned. This is the default value of the deferred word SOURCE. SOURCE Return a string from the current input stream. PARSE-WORD Scan the input stream until char is encountered. Skip over leading chars. Update >IN pointer. Leaves the address and length of the enclosed string. PARSE Scan the input stream until char is encountered. Update >IN pointer. Leaves the address and length of the enclosed string. \ Interactive Layer Parsing 30Sep83map'WORD Leaves the same address as WORD. In this system, 'WORD is the same as HERE. WORD Parse the input stream for char and return a count delimited string at here. Note there is always a blank following it. .( Type the following string on the terminal. ( The Forth Comment Character. The input stream is skipped until a ) is encountered. \ Interactive Layer Dictionary 27AUG83HHL Set up to patch the X word with a blank name of length 0 X The NULL word. Indicates END of input stream TRAVERSE Run through a name field in the specified direction. Terminate when a byte whose high order bit is on is detected. DONE? True if the input stream is exhaused or state doesn't match FORTH-83 Let's hope so. .VERSION Identify the system. \ Interactive Layer Dictionary 27AUG83HHLN>LINK Go from name field to link field. L>NAME Go from link field to name field. BODY> Go from body to code field. NAME> Go from name field to code field. LINK> Go from link field to code field. >BODY Go from code field to body. >NAME Go from code field to name field. >LINK Go from code field to link field. >VIEW Go from code field to view field. VIEW> Go from view field to code field. \ Interactive Layer Dictionary 27AUG83HHLHASH Given a string address and a pointer to a set of vocabulary chains, returns the actual thread. Uses the first character of the string to determine which thread. (FIND) Does a search of the dictionary based on a pointer to a vocabulary thread and a string. If it finds the string in the chain, it returns a pointer to the CFA field inside the header. This field contains the code field address of the body. If it was an immediate word the flag returned is a 1. If it is non-immediate the flag returned is a -1. If the name was not found, the string address is returned along with a flag of zero. Note that links point to links, and are absolute addresses. \ Interactive Layer Dictionary 02AUG83HHL#THREADS The number of seperate linked lists per vocabulary. FIND Run through the vocabulary list searching for the name whose address is supplied on the stack. If the name is found, return the code field address of the name and a non-zero flag. The flag is -1 if the word is non-immediate and 1 if it is immediate. If the name is not found, the string address is returned along with a false flag. DEFINED Look up the next word in the input stream. Return true if it exists, otherwise false. Maybe ignore case. \ Interactive Layer Interpreter 05MAR83HHL?STACK Check for parameter stack underflow or overflow and issue appropriate error message if detected. STATUS Indicate the current status of the system. INTERPRET The Forth Interpret Loop. If the next word is defined, execute it, otherwise convert it to a number and push it onto the stack. \ Extensible Layer Compiler 23JUL83HHLALLOT Allocate more space in the dictionary , Set the contents of the dictionary value on the stack C, Same as , except uses an 8 bit value ALIGN Used to force even addresses. NOOP on 8080s EVEN Makes the top of the stack an EVEN number. COMPILE Compile the following word when this def. executes IMMEDIATE Mark the last Header as an Immediate word. LITERAL Compile the single integer from the stack as a literal DLITERAL Compile the double integer from the stack as a literal. ASCII Compile the next character in the input stream as a literal Ascii integer. CONTROL Compile the next character in the input stream as a literal Ascii Control Character. It must be upper case. \ Extensible Layer Compiler 08Oct83mapCRASH Default routine called by execution vectors. ?MISSING Tell user the word does not exist. ' Return the code field address of the next word ['] Like ' only used while compiling [COMPILE] Force compilation of an immediate word (") Return the address and length of the inline string (.") Type the inline string. Skip over it. ," Add the following text till a " to the dictionary. ." Compile the string to be typed out later. " Compile the string, return pointer later. \ Interactive Layer Dictionary 27Sep83mapFENCE Limit address for forgetting. TRIM (S faddr voc-addr -- ) Change the 4 hash pointers in a vocabulary so that they are all less than a specified value, faddr. (FORGET) (S code-addr relative-link-addr -- ) Forgets part of the dictionary. Both the code address and the header address are specified, and may be independant. (FORGET) resets all of the links and releases the space. FORGET (S -- ) Forget all of the code and headers before the next word. \ Extensible Layer Compiler 16Oct83mapWHERE Locates the screen and position following an error. ERROR Maybe indicate an error. Change this to alter ABORT" (ERROR) Default for ERROR. Conditionally execute WHERE and type message. (ABORT") The Runtime code compiled by ABORT". Uses ERROR, and updates return stack. ABORT" If the flag is true, issue an error message and quit. ABORT Stop the system and indicate an error. \ Extensible Layer Structures 01Oct83map?CONDITION Simple compile time error checking. Usually adequate >MARK Set up for a Forward Branch >RESOLVE Resolve a Forward Branch <MARK Set up for a Backwards Branch <RESOLVE Resolve a Backwards Branch ?>MARK Set up a forward Branch with Error Checking ?>RESOLVE Resolve a forward Branch with Error Checking ?<MARK Set up for a Backwards Branch with Error Checking ?<RESOLVE Resolve a backwards Branch with Error Checking LEAVE and ?LEAVE could be non-immediate. \ Extensible Layer Structures 27JUL83HHLThese are the compiling words needed to properly compile the Forth Conditional Structures. Each of them is immediate and they must compile their runtime routines along with whatever addresses they need. A modest amount of error checking is done. If you want to rip out the error checking change the ?> and ?< words to > and < words, and all of the 2DUPs to DUPs and the 2SWAPs to SWAPs. The rest should stay the same. \ Extensible Layer Defining Words 16Oct83map,VIEW Calculate and compile the VIEW field of the header. HEADER The Header creator. First we lay down the view field. Next we lay down an empty link field since DEFINED will move the next word to HERE. We set up LAST so that it points to our name field, and check for duplicates. Next we link ourselves into the correct thread and delimit the name field bits. CREATE Make a header and initialize the code field. \ Extensible Layer Defining Words 06MAR83HHL!CSP Save the current stack level for error checking. ?CSP Issue error message if stack has changed. HIDE Removes the Last definition from the Dictionary REVEAL Replaces the Last definition in the Dictionary (;USES) Set the code field to the contents of following cellASSEMBLER Define the vocabulary to be filled later. ;USES Similar to the traditional ;CODE except used when run time code has been previously defined. (;CODE) Set the code field to the address of the following. ;CODE Used for defining the run time portion of a defining word in low level code. DOES> Specifies the run time of a defining word in high level Forth. \ Extensible Layer Defining Words 23JUL83HHL[ Stop compiling and start interpreting ] The Compiling Loop. First sets Compile State. Looks up the next word in the input stream and either executes it or compiles it depending upon whether or not it is immediate. If the word is not in the dictionary, it converts it to a number, either single or double precision depending on whether or not any punctuation was present. Continues until input stream is empty or state changes. : Defines a colon definition. The definition is hidden until it is completed, or the user desires recursion. The runtime for : adds a nesting level. ; Terminates a colon definition. Compiles the runtime code to remove a nesting level, and changes STATE so that compilation will terminate. \ Extensible Layer Defining Words 07SEP83HHLRECURSIVE Allow the current definition to be self referencing CONSTANT A defining word that creates constants. At runtime the value of the constant is placed on the stack. VARIABLE A defining word to create variables. At runtime the address of the variable is placed on the stack. DEFER Defining word for execution vectors. These are initially set to display an error message. They are initialized with IS. VOCABULARY Defines a new Forth vocabulary. VOC-LINK is a chain in temporal order and used by FORGET. At runtime a vocabulary changes the search order by setting CONTEXT. DEFINITIONS Subsequent definitions will be placed into CURRENT. \ Extensible Layer Defining Words 07OCT83HHL2CONSTANT Create a double number constant. This is defined for completeness, but never used, so the code field is discarded.2VARIABLE Create a double length variable. This is defined for completeness, but never used, so the code field is discarded. as appropriate. AVOC A variable that hold the old CONTEXT vocabulary CODE is the defining word for FORTH assembler definitions. It saves the context vocabulary and hides the name. END-CODE terminates a code definition and restores vocs. \ Extensible Layer Defining Words 07SEP83HHL#USER Count of how many user variables are allocated USER Vocabulary that holds task versions of defining words ALLOT Allocate some space in the user area for a task. When used with CREATE, you can define arrays this way. CREATE Define a word that returns the address of the next available user memory location. VARIABLE Define a task type variable. This is similar to the old FIG version of USER. DEFER Defines an execution vector that is task local. \ Extensible Layer ReDefining Words 07SEP83HHL>IS Maps a code field into a data field. If the word is in the USER class of words, then the data address must be calculated relative to the current user pointer. Otherwise it is just the parameter field. (IS) The code compiled by IS. Sets the following DEFERred word to the address on the parameter stack. IS Depending on STATE, either sets the following DEFERred word immediatly or compiles the setting for later. \ Initialization High Level 24JUL83HHLRUN Allows for multiline compilation. Thus you may enter a : definition that spans several lines. QUIT The main loop in Forth. Gets more input from the terminal and Interprets it. Responds with OK if healthy. BOOT The very first high level word executed during cold startWARM Performs a warm start, jumped to by vector at hex 104 COLD The high level cold start code. For ordinary forth, BOOT should initialize and pass control to QUIT. \ Initialization High Level 24JUL83HHLINITIAL The screen number to load for an application. OK Loads in an application from the INITIAL screen START Used to compile from a file after meta compilation has finished. BYE Returns control to CP/M. First it moves the heads down next to the code such that the system is contiguous when saved. Calculates the size in pages. \ Initialization Low Level 06MAR83HHL WARM Initialize the warm start entry point in low memory and jump immediately into hi level COLD Initialize the cold start entry point in low memory Then calculate how much space is consumed by CP/M and round it down to an even HEX boundary for safety. We then patch FIRST and LIMIT with this value and calculate the locations of the return stack and the Terminal Input buffer. We also set up the initial parameter stack and finally call the Hi Level COLD start routine. \ Initialize User Variables 27JUL83HHLFinally we must initialize the user variables that were defined earlier. User variables are relocatable, and sit on the top of the dictionary in whatever task they occur in. They must be laid down in the exact same order as their definitions. \ Resident Tools 27Sep83mapDEPTH Returns the number of items on the parameter stack .S Displays the contents of the parameter stack non destructively. Very useful when debugging. .ID Display the variable length name whose name field address is on the stack. If it is shorter than its count, it is padded with underscores. Only valid Ascii is typed. DUMP A primitive little dump routine to help you debug after you have changed the system source and nothing works any more. These words are in the reference word sets, 29Sep83mapand are only include for completeness. We prefer to use RECURSIVE rather than RECURSE. ( See RECURSIVE ) \ Resolve Forward References 06MAR83HHLWe must resolve the forward references that were required in the Meta Compiler. These are all run time code which wasn't known at the time the meta compiling version was defined. Theseare all either defining words or special case immediate words. \ Resolve Forward References 06MAR83HHLThese are forward references that were generated in the course of compiling the system source. Most of these are here because (DO) (?DO) and ROLL are written in high level and are defined very early in the system. While forward references should be avoided when possible, they should not be shunned as a matter of dogma. Since the meta compiler makes it easy to create and resolve forward references, why not take advantage of it when you need to. \ Initialize DEFERred words 02AUG83HHLIn order to run, we must initialize all of the defferred words that were defined to something meaningful. Deferred words are also known as execution vectors. The most important execution vectors in the system are listed here. You can certainly createyour own with the defining word DEFERred. Be sure you initialize them however, or else you will surely crash. \ Initialize Variables 28JUL83HHLInitialize the CURRENT vocabulary to point to FORTH Initialize the CONTEXT vocabulary to point to FORTH Initialize the Threads in the Forth vocabulary The value of DP-BODY is only now know, so we must init it here The rest of the variables that are initialize are ordinary variables, which are resident in the dictionary, and must be correct upon cold boot. You can change some of these depending on how you want your system to come up initially. For example if you do not normally want to ignore case, set CAPS to FALSE instead of true.
